############################################################################## # # /_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/# # / / # # / _/_/_/_/_/ _/_/ _/_/ _/_/ _/_/_/_/ _/_/_/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/_/_/ _/_/ _/_/ _/_/ _/_/_/_/_/_/ _/_/ _/_/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/_/_/_/ _/_/_/_/ _/_/_/_/_/ _/_/ _/_/ _/_/_/_/ / # # / / # #/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ unified # # # ############################################################################## # | Mesoscale and Microscale Meteorology Division (MMM) # # Main contact: | National Center for Atmospheric Research (NCAR) # # | PO Box 3000, Boulder, Colorado 80307-3000, USA. # # Smolarkiewicz Piotr | e-mail: smolar@ncar.ucar.edu # # | phone: (303)-497-8972 # # | fax: (303)-497-8181 # # -------------------------------------------------------------------------- # # Grabowski Wojciech | e-mail: grabow@ncar.ucar.edu - moist version # # Prusa Joseph | e-mail: prusa@ncar.ucar.edu - mesh refinement # # Wyszogrodzki Andrzej | e-mail: andii@ncar.ucar.edu - parallel, graphics # ############################################################################## # ---> FOLLOWING SET QUEUE OPTIONS FOR YOUR MACHINE <--- # # ---> add '#' or delete '#' before proper '#QSUB' option line <--- # # -------------------------------------------------------------------------- # # ---> READY TO WORK ON: Cray T3E,PVP(vector/parallel/MPP); <--- # # ---> SGI O2K; <--- # # ---> Fujitsu VPP700, NEC SX-4B/2A; <--- # # ---> WORKSTATION: SGI,SUN,DEC Alpha,PC Linux; <--- # # ---> WAS WORKING ON: Cray T3D, HP/Convex Exemplar 2K, Compaq; <--- # ############################################################################## # C R A Y -- P V P (ouray,paiute) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #QSUB -r greenlnd -s /bin/csh -la 1cpus -eo -q prem -lt 2000 -lT 2000 -lM 300Mb ############################################################################## # 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 ############################################################################## # 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 ############################################################################## # I B M (bluevista) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Load Sharing Facility (LSF) commands: # bjobs - Show status of running and pending jobs # bhist - Display historical information about your jobs # bkill - kill a job # bhold - hold a job # bqueues - Show configuration of queues # busers - Display information about users and groups # bpeek - Peek at the stderr and stdout of an unfinished job # bacct - Display accounting information for finished job # bhosts - Summarize load on each host # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # QUEUE CPU MAX WALL MEMORY CHARGE AVAILABILITY PRIORITY # special 576 Unlimited 16 GB 1.0 By permission 500 # premium 576 6 hrs. 16 GB 1.5 Any time 300 # regular 576 6 hrs. 16 GB 1.0 Any time 200 # economy 576 6 hrs. 16 GB 0.5 Any time 160 # standby 576 2 hrs. 16 GB 0.1 Any time 100 # share* 16 6 hrs. 16 GB 1.0 Any time 100 # hold** 576 6 hrs. 16 GB 0.33 Automated 104 # debug 16 0.5 hrs. 16 GB 1.0 10am - 6pm ############################################################################## # Fujitsu VPP700 (at ECMWF) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##QSUB -s /bin/csh -eo -q normal ############################################################################## # WORKSTATION SGI,SUN,DEC Alpha,PC Linux # # |- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | # # |--> You need UNIX (Linux) operational system with csh shell <--| # # |--> Check which FORTRAN compiler is in your system and <--| # # |--> set correct compiler options. For executing job do "csh jobname"<--| # # |- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | # #!/bin/csh ############################################################################## ############################################################################## # |--> <--| # # |--> 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 # # MACHINE CPQ - executes on COMPAQ # # -------------------------------------------------------------------------- # # 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 Pass. Interface - MPI (Cray PVP,T3D,T3E;HP;SGI_O2K,IBM) # # # 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)# # -------------------------------------------------------------------------- # # ---> If NPE > 1 then change following parameters (nprocx, nprocy) <--- # # -------------------------------------------------------------------------- # # Type length 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 # ############################################################################## # Tape read / write modes # # # # IORFLAG 0 - Read from tape written in single processor mode # # IORFLAG 1 - Read from tape written in parallel sequential mode # # # # IOWFLAG 0 - Write to the tape in single processor mode # # IOWFLAG 1 - Write to the tape in parallel sequential mode # # -------------------------------------------------------------------------- # # The parallel sequential mode is when the PE0 collect the arrays belonging # # to other processors and write them sequentially to the tape witout # # creating the array containing all grid points in serial processor mode. # # This option decrease substantialy memory requirements but require the # # knowledge of processor configuration during the tape creation # # Check the definition of the "nprcxa, nprcya, npa, mpa" parameters # ############################################################################## # Tape precision definition # # # # IORTAPE 1 - Tape read in default precision (depend on WORD) # # IORTAPE 2 - Force to read from single precision tape # # IORTAPE 3 - Force to read from double precision tape # # # # IOWTAPE 1 - Tape written in default precision (depend on WORD) # # IOWTAPE 2 - Force to write to single precision tape # # IOWTAPE 3 - Force to write to double precision tape # ############################################################################## # case MACHINE == WRK and WORD = 8 and # # only single precision NCAR graphics available # # -------------------------------------------------------------------------- # # 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 - Spectral Plot (Ncar Graphics) - 0 - no plot # # VORTX 1 - Vortex Plot (Ncar Graphics) - 0 - no plot # # VIS5D 1 - Output with format for vis5d program - 0 - no plot # ############################################################################## # Performance analysis: PERFM 1 # # MACHINE PVP --> JUMPVIEW # # MACHINE T3D --> APPRENTICE # # MACHINE T3E --> APPRENTICE # ############################################################################## ############################################################################# ## <--- # #### Determine hostname/user on NCAR systems <--- # ## <--- # ############################################################################# set cwd = `pwd` set user = `whoami` set hname = `uname -n | head -c 2 ` set lname = `uname -s | head -c 2 ` set mach = `uname -n` if($hname == 'be') setenv machname 'bluevista' if($hname == 'bv') setenv machname 'bluevista' if($hname == 'bs') setenv machname 'bluesky' if($hname == 'fr') setenv machname 'frost' if($hname == 'br') setenv machname 'bria' # Briaree at UdeM if($hname == 'co') setenv machname 'cottos' # Cottos at UdeM if($hname == 'pf') setenv machname 'pleiades' if($hname == 'r0') setenv machname 'cineca' if($hname == 'r0') setenv machname 'galileo' if($hname == 'zw') setenv machname 'zwicky' if($hname == 'pa') setenv machname 'parker' ############################################################################# setenv MACHINE IBM # below an automatic NCAR MACHINE configuration if($lname == 'Li') setenv MACHINE LNX if($hname == 'be') setenv MACHINE IBM if($hname == 'bv') setenv MACHINE IBM if($hname == 'bs') setenv MACHINE IBM if($hname == 'fr') setenv MACHINE BGL if($hname == 'pf') setenv MACHINE PLE if($hname == 'zw') setenv MACHINE PLE if($hname == 'pa') setenv MACHINE PLE if($hname == 'r0') setenv MACHINE PLE if($hname == 'no') setenv MACHINE PLE ############################################################################# setenv OBJECT_MODE 32 setenv ANALIZ 0 if ( $ANALIZ > 0 ) then setenv MESSG ONE setenv BATCH 1 setenv NPE 1 set NNODE = 1 setenv WORD 8 setenv SIGNAL_TRAP 0 setenv NCARG 0 else setenv MESSG MPI setenv BATCH 1 setenv WORD 8 setenv SIGNAL_TRAP 0 setenv NCARG 0 setenv NPE 128 endif setenv NTIME 00:01:00 if( $machname == 'bluevista') then setenv NTIME 0:29 #setenv NTIME 2:29 endif if( $machname == 'bluevista') then # briaree: 12 cores per node if ( $ANALIZ == 0 ) then #setenv NPE 256 #setenv NPE 128 #setenv NPE 64 #setenv NPE 100 setenv NPE 32 endif set NNODE = 1 set NNP = 12 endif if( $machname == 'bria') then # briaree: 12 cores per node if ( $ANALIZ == 0 ) then #setenv NPE 1024 #set NNODE = 88 #setenv NPE 512 #set NNODE = 44 #setenv NPE 256 #set NNODE = 22 #setenv NPE 144 #set NNODE = 12 setenv NPE 128 set NNODE = 11 #setenv NPE 64 #set NNODE = 6 #setenv NPE 100 #set NNODE = 9 #setenv NPE 32 #set NNODE = 3 endif set NNP = 12 endif if( $machname == 'cottos') then if ( $ANALIZ == 0 ) then setenv NPE 256 set NNODE = 32 #setenv NPE 128 #set NNODE = 16 #setenv NPE 100 #set NNODE = 13 #setenv NPE 64 #set NNODE = 8 #setenv NPE 32 #set NNODE = 4 endif set NNP = 8 endif if( $machname == 'bria') then #setenv NTIME 00:10:00 #setenv NTIME 02:00:00 #setenv NTIME 06:00:00 #setenv NTIME 00:10:00 #setenv NTIME 48:00:00 #setenv NTIME 72:00:00 setenv NTIME 168:00:00 #setenv NTIME 24:00:00 endif if( $machname == 'cottos') then #setenv NTIME 00:15:00 #setenv NTIME 00:30:00 #setenv NTIME 02:00:00 setenv NTIME 06:00:00 #setenv NTIME 00:10:00 #setenv NTIME 48:00:00 #setenv NTIME 72:00:00 #setenv NTIME 168:00:00 #setenv NTIME 24:00:00 endif setenv NCPUS 1 setenv PLOTR 0 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 0 setenv ENERGY 0 setenv ENERGY2 1 setenv VIS5D 0 setenv NETCDF 0 setenv PERFM 0 ############################################################################# if( $machname == 'frost') then setenv OBJECT_MODE 64 setenv OBJECT_MODE 32 else setenv OBJECT_MODE 32 endif ############################################################################# if( $machname == 'frost') then setenv QUEUE JumboFridays setenv QUEUE default setenv QUEUE debug endif if( $machname == 'bluevista') then #setenv QUEUE economy setenv QUEUE regular #setenv QUEUE premium endif #setenv PROJECT 48500017 #setenv PROJECT 48500018 #setenv PROJECT 39510003 # EDLEE ??? #setenv PROJECT 48500032 # RAL #setenv PROJECT 48500047 # RAL DARPA setenv PROJECT 33010039 # MMM ############################################################################# ## <--- # #### Change working directory <--- # ## <--- # ############################################################################# setenv JOBNAME EULAG_alone #4000 sol days. alphai=20s.d.,iabb=0 # NCAR setenv OUTPUTDIR ${cwd}/ setenv OUTGMETA ${cwd}/gmetaA.$JOBNAME setenv DIR /ptmp/${user}/$JOBNAME # ncar graphics location setenv NCARG_ROOT /usr/local setenv NCARG_LIB /usr/local/lib32/r8i4 ##setenv NCARG_LIB /usr/local/lib32/r4i4 if( $machname == 'bria' || $machname == 'cottos') then setenv DIR $SCRATCH/$JOBNAME endif if( $machname == 'pleiades' || $machname == 'zwicky') then echo 'PLEIADES CLUSTER ... OK' setenv OUTPUTDIR ${cwd}/ setenv OUTGMETA ${cwd}/$JOBNAME setenv DIR ${cwd}/$JOBNAME setenv SRCDIR ${cwd}/ endif if( $machname == 'cineca' || $machname == 'parker' ) then echo 'CINECA CLUSTER ... OK' setenv OUTPUTDIR ${cwd}/ setenv OUTGMETA ${cwd}/$JOBNAME setenv DIR ${cwd}/$JOBNAME setenv SRCDIR ${cwd}/ endif if( $machname == 'galileo') then echo 'CINECA CLUSTER ... OK' setenv OUTPUTDIR ${cwd}/ setenv OUTGMETA ${cwd}/$JOBNAME setenv DIR ${cwd}/$JOBNAME setenv SRCDIR ${cwd}/ endif if(! -d $DIR ) then mkdir -p -m 775 $DIR || true endif cd $DIR # mv -f fort.9 fort.10 || true # mv -f fort.11 fort.12 || true # mv -f fort.14 fort.15 || true pwd ############################################################################# # ---> <--- # # ---> Read input data file(s) <--- # # ---> <--- # ############################################################################# #cp /ptmp/prusa/DATA/GLOBAL.16/BINARIES/fort_data.feb03.27a fort.10 #cp /ptmp/prusa/DATA/GLOBAL.1/fort_data.feb03.15a fort.10 #cp /ptmp/prusa/DATA/GLOBAL.12/fort_data.nov02.26b fort.10 #msread fort.10 /PRUSA/HPTAUM800b/ftn10 #cp fort.9 fort.10 # #HP fortran files have names "ftn10", ftn09" - oposite to #Cray fortran file names "fort.10", "fort.9" ############################################################################# # ---> <--- # # ---> SPECIFIC SETUP FOR DIFFERENT MACHINES <--- # # ---> <--- # ############################################################################# ############################################################################# if ($MACHINE == LNX) then ############################################################################# ###################################################### if ( $machname == 'bria' ) then ###################################################### echo 'bria COMPILATION' setenv PNETCDFINC /home/cossette/pnetcdf/pnetcdf-1.1.1/include setenv PNETCDFLIB /home/cossette/pnetcdf/pnetcdf-1.1.1/lib cat >! run_paral << '\eof' #!/bin/bash #PBS -l nodes=NNODE:ppn=NNP ##PBS -l mem=10000mb #PBS -l walltime=NTIME #PBS -M cossette@astro.umontreal.ca #PBS -m abe #PBS -N 2DB-1 #PBS -j oe #Initialization set verbose set echo # Go into case directory cd $PBS_O_WORKDIR/ echo $PBS_O_WORKDIR module load intel-compilers/12.0.4.191 module load MPI/Intel/mvapich2/1.6 #Run Eulag in case directory #scan aprun -n NPE ./a.out mpiexec -n NPE ./a.out >o '\eof' sed -e "s#NPE#$NPE#g" run_paral > tmp mv tmp run_paral sed -e "s#NTIME#$NTIME#g" run_paral > tmp mv tmp run_paral sed -e "s#NNODE#$NNODE#g" run_paral > tmp mv tmp run_paral sed -e "s#NNP#$NNP#g" run_paral > tmp mv tmp run_paral echo "Submitting to queque on bria" echo $NNP #exit #else #endif ###################################################### endif ## bria ###################################################### ###################################################### if ( $machname == 'cottos' ) then ###################################################### echo 'cottos COMPILATION' setenv PNETCDFINC /home/cossette/pnetcdf/pnetcdf-1.1.1/include setenv PNETCDFLIB /home/cossette/pnetcdf/pnetcdf-1.1.1/lib cat >! run_paral << '\eof' #!/bin/bash #PBS -l nodes=NNODE:ppn=NNP ##PBS -l mem=10000mb #PBS -l walltime=NTIME #PBS -M cossette@astro.umontreal.ca #PBS -m abe #PBS -N 2DB-1 #PBS -j oe #Initialization set verbose set echo # Go into case directory cd $PBS_O_WORKDIR/ echo $PBS_O_WORKDIR module load openmpi_intel64 #Run Eulag in case directory #scan aprun -n NPE ./a.out mpirun -n NPE ./a.out >o '\eof' sed -e "s#NPE#$NPE#g" run_paral > tmp mv tmp run_paral sed -e "s#NTIME#$NTIME#g" run_paral > tmp mv tmp run_paral sed -e "s#NNODE#$NNODE#g" run_paral > tmp mv tmp run_paral sed -e "s#NNP#$NNP#g" run_paral > tmp mv tmp run_paral echo "Submitting to queque on cottos" echo $NNP #exit #else #endif ###################################################### endif ## cottos ###################################################### ###################################################### endif ###LNX ###################################################### ######################### if ($MACHINE == IBM) then ######################### if( $machname == 'bluevista') then setenv OBJECT_MODE 64 setenv NCARG_LIB /usr/local/lib64/r4i4 ######################### if ($MESSG == MPI) then /usr/bin/rm -f run_paral cat > run_paral << '\eof' #!/usr/bin/ksh #BSUB -W NTIME # cpu time limit #BSUB -x # exclusive use of node (not_shared) #BSUB -a poe # select poe ###BSUB -R "span[ptile=8]" # run a max of 8 tasks per node #BSUB -n NPE # number of tasks #BSUB -J SUFFIX.NPE # job name #BSUB -e OUTPUTDIR/out.SUFFIX.NPE # output filename #BSUB -o OUTPUTDIR/out.SUFFIX.NPE # input filename ##BSUB -q premium # queue #BSUB -q regular # queue ##BSUB -q economy # queue #BSUB -P 33010039 set -ex cd PATH pwd date export OBJECT_MODE=OBJECT_MODE # MPI runtime settings export MP_PROCS=NPE export MP_SHARED_MEMORY=yes export MP_WAIT_MODE=poll export XLSMPOPTS="parthds=1:stack=50000000 : spins=500000 : yields=50000" export MP_COREFILE_FORMAT=STDERR export MPI_BUFS_PER_PROC=256 export MPI_NAP=yes #export MPI_INFOLEVEL=2 export MP_EUILIB=us export MP_LABELIO=yes export MP_EAGER_LIMIT=64000 export XLFRTEOPTS=err_recovery=no:buffering=disable_preconn ulimit -a echo "System load: $(uptime)" mpirun.lsf ./a.out date exit '\eof' sed -e "s#OUTPUTDIR#$OUTPUTDIR#g" -e "s#PATH#$DIR#g" run_paral > tmp mv tmp run_paral sed -e 's#OBJECT_MODE$#'$OBJECT_MODE'#g' run_paral > tmp mv tmp run_paral sed -e 's/SUFFIX/'$JOBNAME'/g' run_paral > tmp mv tmp run_paral sed -e 's/NPE/'$NPE'/g' run_paral > tmp mv tmp run_paral sed -e 's/NNODE/'$NNODE'/g' run_paral > tmp mv tmp run_paral endif ####################### if ($MESSG == ONE) then rm -f run_serial rm -f *.gks cat > run_serial << '\eof' #!/usr/bin/ksh # # LSF batch script to run a serial code # #BSUB -c NTIME # cpu time limit #BSUB -n 1 # number of tasks #BSUB -J SUFFIX.NPE # job name #BSUB -e OUTPUTDIR/out.SUFFIX.NPE # output filename #BSUB -o OUTPUTDIR/out.SUFFIX.NPE # input filename #BSUB -q premium # queue ##BSUB -q regular # queue #BSUB -P 33010039 set -ex ## NCAR OPTION # export NCARG_LIB=/usr/local/lib64/r8i4 export NCARG_LIB=/usr/local/lib64/r4i4 export NCARG_ROOT=/usr/local export OBJECT_MODE=OBJECT_MODE ### cd PATH pwd date mv -f gmeta gmeta.old || true # mv -f fort.9 fort.10 || true # mv -f fort.11 fort.12 || true # mv -f fort.14 fort.15 || true ./a.out date cp gmeta OUTGMETA exit '\eof' sed -e "s#OUTPUTDIR#$OUTPUTDIR#g" -e "s#PATH#$DIR#g" run_serial > tmp mv tmp run_serial sed -e 's#OBJECT_MODE$#'$OBJECT_MODE'#g' run_serial > tmp mv tmp run_serial sed -e "s#OUTGMETA#$OUTGMETA#g" run_serial > tmp mv tmp run_serial sed -e 's#PATH#'$DIR'#g' run_serial > tmp mv tmp run_serial sed -e 's/SUFFIX/'$JOBNAME'/g' run_serial > tmp mv tmp run_serial sed -e 's/NTIME/'$NTIME'/g' run_serial > tmp mv tmp run_serial endif endif endif ######################### if( $machname == 'bluesky') then ######################### if ($MESSG == MPI) then /usr/bin/rm -f run_paral cat > run_paral << '\eof' # @ shell = /usr/bin/ksh # @ core_limit = 4096 # @ restart = no # @ job_cpu_limit = 9000,8950 # @ job_name = SUFFIX.NPE # @ output = OUTPUTDIR/out.$(job_name) # @ error = OUTPUTDIR/out.$(job_name) # @ job_type = parallel # @ network.MPI = csss,not_shared,US,HIGH # @ node_usage = not_shared # @ total_tasks = NPE # @ node = NNODE ## @ resources = ConsumableCpus(1) ConsumableMemory(700Mb) ## @ class = np # @ account_no = 33010039 ## @ account_no = 54042108 # @ class = com_rg8 # @ queue set -ex cd PATH pwd date export OBJECT_MODE=OBJECT_MODE # MPI runtime settings export MEMORY_AFFINITY=MCM export MP_AFFINITY=MCM export MP_PROCS=NPE export MP_SHARED_MEMORY=yes export MP_WAIT_MODE=poll export XLSMPOPTS="parthds=1:stack=50000000 : spins=500000 : yields=50000" export MP_COREFILE_FORMAT=STDERR export MPI_BUFS_PER_PROC=256 export MPI_NAP=yes #export MPI_INFOLEVEL=2 export MP_EUILIB=us export MP_LABELIO=yes export MP_EAGER_LIMIT=64000 export XLFRTEOPTS=err_recovery=no:buffering=disable_preconn export MP_CPU_USE=unique ulimit -a echo "System load: $(uptime)" # large page support #/usr/ccs/bin/ldedit -blpdata ./a.out export DISPLAY=cormac:0.0 #totalview poe -searchPath=/hpcu/fdb/naw/QBO.viscous.3D.noslip.shallow.water -a a.out poe a.out date exit '\eof' sed -e "s#OUTPUTDIR#$OUTPUTDIR#g" -e "s#PATH#$DIR#g" run_paral > tmp mv tmp run_paral sed -e 's#OBJECT_MODE$#'$OBJECT_MODE'#g' run_paral > tmp mv tmp run_paral sed -e 's/SUFFIX/'$JOBNAME'/g' run_paral > tmp mv tmp run_paral sed -e 's/NPE/'$NPE'/g' run_paral > tmp mv tmp run_paral sed -e 's/NNODE/'$NNODE'/g' run_paral > tmp mv tmp run_paral endif ####################### if ($MESSG == ONE) then rm -f run_serial cat > run_serial << '\eof' #!/bin/ksh # @ shell = /usr/bin/ksh # @ job_type = serial ## @ node_usage = not_shared # @ output = OUTPUTDIR/out.SUFFIX # @ error = OUTPUTDIR/out.SUFFIX # @ class = ns # @ core_limit = 4096 # @ job_cpu_limit = 2880,2880 # @ class = com_pr8 ## @ class = interactive ## @ cpu_limit = unlimited ## @ account_no = 33010039 ## @ checkpoint = no # @ queue set -ex ## NCAR OPTION export NCARG_LIB=/usr/local/lib32/r8i4 export NCARG_ROOT=/usr/local # export MP_CPU_USE=unique cd PATH pwd date mv -f gmeta gmeta.old || true # mv -f fort.9 fort.10 || true # mv -f fort.11 fort.12 || true ./a.out date cp gmeta OUTGMETA exit '\eof' sed -e "s#OUTPUTDIR#$OUTPUTDIR#g" -e "s#PATH#$DIR#g" run_serial > tmp mv tmp run_serial sed -e 's#OBJECT_MODE$#'$OBJECT_MODE'#g' run_serial > tmp mv tmp run_serial sed -e "s#OUTGMETA#$OUTGMETA#g" run_serial > tmp mv tmp run_serial sed -e 's#PATH#'$DIR'#g' run_serial > tmp mv tmp run_serial sed -e 's/SUFFIX/'$JOBNAME'/g' run_serial > tmp mv tmp run_serial endif endif endif ############################################################################# # ---> <--- # # ---> SET MODEL PARAMETERS IN THE INCLUDED FILES <--- # # ---> <--- # ############################################################################# goto DEFAULT_SETUP RETURN_FROM_DEFAULT: rm -f param.nml rm -f param.ior rm -f param.icw rm -f param.v5d rm -f vrtstr.fnc rm -f vrtstr.mds rm -f msg.inc rm -f msg.lnk rm -f tempr.def rm -f tempw.def rm -f msg.lnp rm -f conrec.gks rm -f velvct.gks rm -f colorpl.gks rm -f cfftpack.f rm -f v5d43.c rm -f v5d43.h ######################### cat > param.nml << '\eof' c +++param.nml+++ c grid size and basic physical option parameters ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C **** WARNING: if using multiprocessing, there exist constraint C **** on values of m,n. See note below on "msg.inc" file C **** and values of nprocx and nprocy. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (lagr=0,ieul=1-lagr) ! Lagrangian/Eulerian model parameter (n=32,m=32,l=32)! grid dimensions, stable layer SCZ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c lxyz - define meaning of dx00, dy00, dz00 c---> lxyz=0 physical grid increments, need to specify values of dx,dy,dx c---> lxyz=1 physical domain lengths, need to specify values of dx,dy,dx c---> lxyz=2 normalized grid increments, do not need values of dx,dy,dx c ------------------------------------------------------------------------- c --- Cartesian (all units in meters and seconds) c --- Spherical (all units in meters and seconds) c --- dx00, dy00, dz00 - domain grid increments/dimensions c --- dt00 - time step increment in seconds ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (dx00=1.) parameter (dy00=1.) c parameter (dz00=3945826.7716) !r_max = 0.95, l=64 parameter (dz00=8700187.5) !r_max = 1.0, l=32 c parameter (dz00=16572472.411199998) !r_max = 0.95, l=16 parameter (dt00=5000.) parameter (lxyz=0) ccoccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- nt: number of timesteps c --- nth: max NT for histories c --- noutp: print diagnostic output/graphics plot after every "noutp" step c --- nplot: store abbreviated tape every "nplot" step (iowritesh) -- fort.11 c --- nstore: store full dataset after every "nstore" step -- fort.9 c---> nslice: store data for the graphics postprocessing c--->nbridge: send data to foreign code every "nbridge" step ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c parameter (nt=5*14400,noutp=360,nplot=1440,nstore=1440,nslice=0) !10 s.d. c parameter (nt=20*14400,noutp=360,nplot=1440,nstore=1440,nslice=0) !10 s.d. parameter (nt=1440000,noutp=360,nplot=5000,nstore=1440000, .nbridge=1,nslice=0) !1000 s.d. c parameter (nt=5760000,noutp=360,nplot=7200,nstore=28800, c .nslice=0) !4000 s.d. c parameter (nt=2501,noutp=25,nplot=100,nstore=2502,nbridge=1, c .nslice=0) !4000 s.d. c parameter (nt=2880,noutp=7,nplot=72,nstore=72, !100 Sd dt=0.5h c parameter (nt=100,noutp=10,nplot=10,nstore=100, c .nslice=0) !4000 s.d c parameter (nt=1000,noutp=100,nplot=100,nstore=100,nslice=0) parameter (nth=nt+1) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c---> nslice: store 2D slice data (binary or Netcdf) for the postprocessing c---> nxaver: save 2D data averaged in the zonal direction ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nxaver=7200) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- iwrite: 1 make history tape on unit 9 (fort.9) c --- iwrite0: 0 do not save/1 save the initial data on restart c --- irst: 1 restart run from history tape (fort.10) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! parameter (iwrite=1,iwrite0=0,irst=1) parameter (iwrite=1,iwrite0=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c CREATE RESTART/GRAPHICS/ANALYSIS PARAMETERS c --- nfil: number of output files generated in the tape (if iwrite=1) c --- nfilm: parameter used to exclude initial "0" time step (if iwrite0=1) c --- dt_fil: timestep used in the tape run c --- nt_fil0: time step number for the first output: c 1) =0 initial (diagnostic) time step (if iwrite0=1) c 2) =nt_film0 all outputs from prognostic time steps (iwrite0=0) c ---nt_film0: time step increments for consecutive outputs c nt_film0=nstore (value of "nstore" from the tape run) c --- nfstart: first record in tape file to read c 1) ANALIZ=0,irst=0 for initialization (fort.10) c 2) ANALIZ>0 for analysis (fort.10 or fort.12) c --- nanlfl: switch between output tapes c 1) =0 short tape fort.12 for graphisc only c 2) =1 full tape fort.10 for graphics and diagnostic c --- ndia: flag for diagnostics during analyasis (only if nanlfl=1) c --- nplo: frequency of the plots, analyse every nplo'th record ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nfil =2, nfilm =nfil -1) c parameter (nfilo=151, nfilom=nfilo-1) parameter (nfilo=301, nfilom=nfilo-1) c parameter (nfilo=601, nfilom=nfilo-1) parameter (dt_fil =1800,nt_fil0 =0,nt_film0 =2880) parameter (dt_filo=1800,nt_filo0=0,nt_filom0 =2880) parameter (nfstart=1) parameter ( nanlfl=1) parameter ( idia=1 *nanlfl) parameter ( nplo=1) ccoccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Monge-Ampere equation c --- iouter : number of newton krylov outer iterations c --- innel : number of elliptic solver iterations c --- iprecc : preconditionner c --- ivar : Richardson / Min res. precon. c --- inpr : number of iterations in precon. c --- lrdl : GCRMA(k) c --- ioutp : print satistics c --- iowr : print to tape (fort.15) C...Newton-Krylov solver parameter (itsmx=1, . iouter=20, . innel=30, . lrdl=2, . ioutp=1, . iprecc=0, . idouble=1, . ivar=2, . iowr=0, . ispectra=1) C...Richardson solver parameter(itricha=100) C...Precondtionners parameter(inpr=1,ioutpr=0) !output C...ADI parameter(iadi=5,adtf=1.) C...Richardson parameter(iri=1,ipj=0,betap=.25) C...Domain Decomposition parameter(idom=0) C...Domain Decomposition parameter(mabeg=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nspec=n/2, .iospc=18,ioell1=10,ioell2=10,iohis=30) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c boundaries c --- icyx,icyy,icyz: boundaries are open (=0) or periodic (=1) c --- in x,y,z coordinates c --- irelx,irely: do not apply (=0) or apply damping (=1) c --- along x,y boundaries ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (icyx=1) parameter (icyy=0) parameter (icyz=0) parameter (irelx=0,irely=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Dry/Moist model parameters ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (moist=0) ! Dry/Moist model parameter (ice=0) ! warm rain =0/ simple ice =1 parameter (iceab=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Viscous/Inviscid model parameters ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ivs0=1) ! Viscous/Inviscid model parameter (irid0=0) ! Viscous/Inviscid model parameter (itke0=0,itke=ivs0*itke0) ! Smagorinsky/TKE SGS model parameter (nthv=nth,nthv2=2*nthv,nthv4=4*nthv,nthvio=iohis*nthv) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Chemistry on-off ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ichm=1,nspc=2) ! chemical spices parameter (nthch=nspc*nthv) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Basic physical/numerical parameters c c --- implgw = 1 advect theta perturbation (default) c --- 0 advect full theta c --- isphere = 0 reference coordinates are Cartesian c --- (need to specify dx,dy,dz in blanelas) c --- 1 reference coordinates are spherical c --- (need to specify only dz in blanelas) c --- icorio = 0 no coriolis accelerations c --- 1 incorporate coriolis accelerations c --- (need to set icorio even if isphere=1) c --- icylind =0 reference coordinates are Cartesian c --- reference coordinates are cylindrical c --- ientro = 1 use entropy as thermodyn. var. (default) c --- 0 use theta c c --- istab = 1 run with stable layer below SCZ (default) c --- 0 run SCZ without stable layer below c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (implgw=1,isphere=1,icylind=0,icorio=1) parameter (intz=1-implgw) parameter (pflip=-1) parameter (ientro=0,istab=1) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c spectral preconditioner ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(ispcpr=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c immersed boundary ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(imrsb=0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c icw ontrols lateral open boundaries: c icw=0 "overspecified" enforces component w=0 at the open boundaries; c icw=0 makes sense only with absorbers ON c icw=1 "correct" does not invoke components other than normal; ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (icw=1) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- time of time integration c--> itraj0=0 adams-bashf., itraj0=1 runge-kutta ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(itraj=0) ! Ad-Bs/Rg-Kt advecting flow 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 (nkv=(n-1)*ivs0+1 ,mkv=(m-1)*ivs0+1 ,lkv=(l-1)*ivs0+1) parameter (nke=(n-1)*itke+1 ,mke=(m-1)*itke+1 ,lke=(l-1)*itke+1) parameter (nch=(n-1)*ichm+1 ,mch=(m-1)*ichm+1 ,lch=(l-1)*ichm+1) parameter (nts=(n-1)*itraj+1,mts=(m-1)*itraj+1,lts=(l-1)*itraj+1) parameter (nib=(n-1)*imrsb+1,mib=(m-1)*imrsb+1,lib=(l-1)*imrsb+1) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- Magnetohydrodynamic module c---> mhd=1 : activate MHD c---> ibbc=1 : time-varying boundary conditions (subroutine bbeset) c---> ibbu=0 : zero magnetic field at upper surface c---> ibbu=1 : radial magnetic field at upper surface c---> ibbl=0 : zero magnetic field at lower surface c---> ibbl=1 : radial magnetic field at lower surface c---> idvcln=1 : divergence cleaning on/off c---> idisb=1 : magnetic dissip ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (mhd=0,ibbu=1,ibbl=0) parameter (nmhd=(n-1)*mhd+1,mmhd=(m-1)*mhd+1,lmhd=(l-1)*mhd+1) '\eof' ######################### cat > param.v5d << '\eof' ! parameter(iconv= 0,idiv=1) parameter(iconv=-1,idiv=1,iuvsf=0) parameter(nd1=1,nd2=n) ! nd1=100,nd2=200 parameter(md1=1,md2=m) ! md1=80,md2=200 parameter(ld1=1,ld2=l) ! ld2=31 parameter(nd=(nd2-nd1+1)/idiv) parameter(md=(md2-md1+1)/idiv) parameter(ld=(ld2-ld1+1)/idiv) '\eof' ######################### cat > vrtstr.mds << '\eof' ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc control parameters and fortran statement functions for vertical stretching ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! parameter (istr=0,SD=7000.) parameter (istr=0,SD=20.) common /zstrch/ zstr(l) '\eof' #! GGstr: stretiching Chan&Sofia cat > vrtstr.fnc << '\eof' ! fs(zt) = istr*(exp((zb - zt)*log(1. + SD)/zb) - 1.)/SD fs(za)= istr*(1.-exp(-za/SD)) +(1-istr)*za fsi(zt)=-istr*SD*alog(1.-istr*zt/zb*fs(zb))+(1-istr)*zt fsk(zk)=zb/fs(zb)*fs(zk) '\eof' ######################### cat > param.ior << '\eof' c +++param.ior+++ c---> ior=order of SL remapping accuracy/2; c---> only even order schemes are considered parameter (ior=2,iorj=2) c---> ihlag is a SL halo size; ihlag .ge. max(C, ior + 1, 3) parameter (ihlag=10) ! ior=1,2 ihlag=3 ; ior=3 ihlag=4 '\eof' ######################### touch msg.inc if ($NPE == 1) then cat >> msg.inc << '\eof' c NEVER CHANGE THESE TWO PARAMETERS! parameter (nprocx=1, nprocy=1) !processor geometry parameters c parameter (nprcxa=nprocx, nprcya=nprocy) parameter (nprcxa=1, nprcya=1) '\eof' else cat >> msg.inc << '\eof' c YOU CAN CHANGE FOLLOWING PARAMETERS: c nprocx and nprocy are specifying number of parallel c subdomains, ie. how full domain is subdivided in x and y c *************************************************************** c *************************************************************** c *** WARNING: n/nprocx and m/nprocy MUST be integer *** c *** This constrains all four of these variables *** c *************************************************************** c *************************************************************** parameter (nprocx=4, nprocy=2) !processor geometry parameters c parameter (nprocx=6, nprocy=1) !processor geometry parameters c parameter (nprocx=8, nprocy=4) !processor geometry parameters c parameter (nprocx=8, nprocy=8) !processor geometry parameters c parameter (nprocx=10, nprocy=10) !processor geometry parameters c parameter (nprocx=12, nprocy=12) !processor geometry parameters c parameter (nprocx=16, nprocy=8) !processor geometry parameters c parameter (nprocx=16, nprocy=16) !processor geometry parameters c parameter (nprocx=32, nprocy=16) !processor geometry parameters c parameter (nprocx=32, nprocy=32) !processor geometry parameters c parameter (nprocx=18, nprocy=8) !processor geometry parameters c *************************************************************** c *************************************************************** parameter (nprcxa=nprocx, nprcya=nprocy) '\eof' endif cat >> msg.inc << '\eof' c ih is halo width parameter (ih=3) !processor geometry parameters parameter (nproc=nprocx*nprocy) parameter (np=n/nprocx, mp=m/nprocy) parameter (npa=n/nprcxa, mpa=m/nprcya) c dimensions for moist msg arrays parameter (nmsp=np*moist+(1-moist), . mmsp=mp*moist+(1-moist)) ! dimensions for mhd msg arrays !mod_run parameter (nmhdp=np*mhd + 1*(1-mhd), . mmhdp=mp*mhd + 1*(1-mhd)) c dimensions for ice A, ice B msg arrays parameter (nicp=np*iceab + (1-iceab), . micp=mp*iceab + (1-iceab)) c dimension for tke msg arrays parameter (nkep=np*itke + (1-itke), . mkep=mp*itke + (1-itke)) c dimension for tkv msg arrays parameter (nkvp=np*ivs0 + (1-ivs0), . mkvp=mp*ivs0 + (1-ivs0)) c dimension for traj msg arrays parameter (ntsp=np*itraj + (1-itraj), . mtsp=mp*itraj + (1-itraj)) c dimension for chm msg arrays parameter (nchp=np*ichm + (1-ichm), . mchp=mp*ichm + (1-ichm)) c dimension for bu msg array (integz=1 option) parameter(ntzp=np*intz + (1-intz), . mtzp=mp*intz + (1-intz), . ltz= l*intz + (1-intz)) c dimension for mmersed boundary arrays parameter (nibp=np*imrsb + 1*(1-imrsb), . mibp=mp*imrsb + 1*(1-imrsb)) c dimension for prc_bcz msg arrays parameter (npcz=np*icyz + (1-icyz), . mpcz=mp*icyz + (1-icyz), . lcz= l*icyz + (1-icyz)) c dimension for prc_f msg arrays parameter (nspp=np*ispcpr + (1-ispcpr), !physical space . mspp=mp*ispcpr + (1-ispcpr), . lspp= l*ispcpr + (1-ispcpr)) parameter (nssp=np*ispcpr + (1-ispcpr), !spectral space . mssp=mp*ispcpr + (1-ispcpr), . lssp= l*ispcpr + (1-ispcpr)) parameter (nspct=n*ispcpr + (1-ispcpr), !total spct. space . mspct=m*ispcpr + (1-ispcpr)) integer my_row_sp,my_col_sp common/spectral_cyc/ my_row_sp(nprocy),my_col_sp(nprocx) 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 integer iup,iupx,iupy common/iupdate/ iup,iupx,iupy '\eof' touch src.F goto SET_PRECOMPILATOR RETURN_SET_PRECOMPILATOR: ############################################################################# #### #### #### 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 << '\eof' #define SEMILAG 0 /* 0=EULERIAN, 1=SEMI-LAGRANGIAN */ #define MOISTMOD 0 /* 0=DRY, 1=WARM MOIST, 2=ICE A+B (NOT READY YET) */ #define MHD 0 /* 0=Hydro, 1=Magnetohydrodynamics */ #define J3DIM 1 /* 0=2D MODEL, 1=3D MODEL */ #define SGS 0 /* 0=NO DIFFUSION, 1=OLD DISSIP, 2=DISSIP AMR */ #define SUMR16 0 /* 0=REAL*8, 1=REAL*16 for GLOBAL SUMS */ #define ISEND 2 /* 1=SENDRECV, 2=IRECV+SEND, 3=ISEND+IRECV */ #define PRECF 0 /* 0=PRECON_DF or PRECON_BCZ, 1=PRECON_F */ #define POLES 1 /* 0=NO FLOW OVER POLES, 1=FLOW OVER POLES ON */ #define IORFLAG 0 /* 0=tape in serial mode, 1=tape in parallel mode */ #define IOWFLAG 0 /* 0=tape in serial mode, 1=tape in parallel mode */ #define IORTAPE 2 /* 1=default, 2=single, 3=double precision */ #define IOWTAPE 2 /* 1=default, 2=single, 3=double precision */ #define TIMEPLT 0 /* 1=time counts */ c.....7..0.........0.........0.........0.........0.........0.........012 PROGRAM ANELAS c.....7..0.........0.........0.........0.........0.........0.........012 c c set grid sizes with parameter statements include 'param.nml' include 'param.ior' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #endif real globmax,globmin,globsum parameter (nml=n*m*l,nm=n*m,ml=m*l,nmp=np*mp) parameter (nmsgs=n*m,nmmsgs=nms*mms) parameter(nmsgsp=(np+2*ih)*(mp+2*ih), . nmmsgsp=(nmsp+2*ih)*(mmsp+2*ih)) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/histape/ dtfil(nfil ),dtfilo(nfilo), . ntfil(nfil ),ntfilo(nfilo), . nrestr,nresto cccccccccccccccccccccccccccccccccccccccccccccccccccc #if (HP > 0 || SGI_O2K > 1) integer CRAYOPEN,CRAYCLOSE #endif common/hpcray/ ifcw,ifcr,ioptw,ioptr cccccccccccccccccccccccccccccccccccccccccccccccccccc common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check - modified c dimension of ip due to out of bound problem in routine UPDATEBTW c for n1 common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar common/znave/ uza(mp,l),vza(mp,l),wza(mp,l),thza(mp,l), . qvza(mmsp,lms),bxza(mmhdp,lmhd),byza(mmhdp,lmhd), . bzza(mmhdp,lmhd) common/vbcdg/ vbcdiag(9) ccccccccccccccccccccccccc constants for pressure solver; itp_,epp_ are max number of iterations and constraint of accuracy max|1/rho*div(rho*v)*dt| 0) check if reference conditional instability may occur if(moist.eq.1) call cndinst #endif create boundary values for velocity call velbc(ue,ve,rho) c---------------------------------------------------------- create random perturbations in initial data; see noise routine for details; corporate noise ft into desired fields, e.g., th=the+0.001*ft, etc. inoise=0 if(inoise.eq.1) then call noise(fx,fy,fz,0) c call filstr(fz) c do k=1,l c do j=1,mp c do i=1,np cc if(fz(i,j,k).gt.0.1) then c if(fz(i,j,k).gt.0.01) then c zsib(i,j,k)= 1. c else c zsib(i,j,k)=-1. c endif c enddo c enddo c enddo c call update(zsib,np,mp,l,np,mp,iup) else do k=1,l do j=1,mp do i=1,np fx(i,j,k)=0.0 fy(i,j,k)=0.0 fz(i,j,k)=0.0 enddo enddo enddo endif CCCCCCC READ DATA FROM TAPE FORT.20 C icomm=1 C if (mype.eq.0) then C call iovelread0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), C . w(1-ih,1-ih,1,0),icomm,20) C else C call iovelreadk(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), C . w(1-ih,1-ih,1,0),icomm) C end if c call integz(u(1-ih,1-ih,1,0),fy) c call integz(v(1-ih,1-ih,1,0),fy) c call integz(w(1-ih,1-ih,1,0),fy) CCCCCCC END READ DATA FROM TAPE call noise(fx,fy,fz,0) !mod do 4 k=1,l do 4 j=1,mp do 4 i=1,np ia = (npos-1)*np + i ja = (mpos-1)*mp + j if (istab.eq.1.and.zcr(k).le.hpsl) then u(i,j,k,0)=0. v(i,j,k,0)=0. w(i,j,k,0)=0. th(i,j,k)=0. else th(i,j,k) =1.e-2*fx(i,j,k) ! introduce theta perturbation u(i,j,k,0)= 0. v(i,j,k,0)= 0. w(i,j,k,0)= 0. if (k.eq.l) th(i,j,k)=0. !mihai endif g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k,0)=g11*u(i,j,k,0)+g21*v(i,j,k,0) oy(i,j,k,0)=g12*u(i,j,k,0)+g22*v(i,j,k,0) oz(i,j,k,0)=g13*u(i,j,k,0)+g23*v(i,j,k,0)+g33*w(i,j,k,0) p(i,j,k) =0. x0(i,j,k) =float(ia) y0(i,j,k) =float(ja) z0(i,j,k) =float(k) fx(i,j,k) =1. fy(i,j,k) =0. fz(i,j,k) =1. 4 ft(i,j,k) =1. if(ichm.eq.1) then do ispc=1,nspc do k=1,l do j=1,mp do i=1,np chm(i,j,k,ispc) = 0. fchm(i,j,k,ispc) = 0. pfy(i,j,k)=0. enddo enddo enddo call sumcns(chm(1-ih,1-ih,1,ispc),pfy,rho,hischm(1,ispc),1) enddo endif !ichm #if (MOISTMOD > 0) create moist initial conditions do 40 k=1,l do 40 j=1,mp do 40 i=1,np qv(i,j,k)=qve(i,j,k) qc(i,j,k)=0. qr(i,j,k)=0. thf(i,j,k)=th(i,j,k)+the(i,j,k) fqv(i,j,k)=0. fqc(i,j,k)=0. fqr(i,j,k)=0. 40 ftf(i,j,k)=0. #endif create omega force for itraj=1 trajectory (advective velocity) scheme if(itraj.eq.1) then do 41 k=1,l do 41 j=1,mp do 41 i=1,np fox(i,j,k) =0. foy(i,j,k) =0. 41 foz(i,j,k) =0. endif compute poisson equation for potential c if(ispcpr.eq.1) call spcpri call gcrk( p,pfx,pfy,pfz,ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), . fx,fy,fz,ft,ub,vb,ob,itp0,epp0,0,1) c . fx,fy,fz,ft,itp0,epp0,0) call prforc(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), . fx,fy,fz,ft,ub,vb,ob,1) c . fx,fy,fz,ft) initprs=1 call mybarrier() do 5 k=1,l do 5 j=1,mp do 5 i=1,np p(i,j,k)=0. fx(i,j,k)=0. fy(i,j,k)=0. fz(i,j,k)=0. ft(i,j,k)=0. ox(i,j,k,0)=pfx(i,j,k) oy(i,j,k,0)=pfy(i,j,k) oz(i,j,k,0)=pfz(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) u(i,j,k,0)= (g22*ox(i,j,k,0)-g21*oy(i,j,k,0))/(g22*g11-g12*g21) v(i,j,k,0)=-(g12*ox(i,j,k,0)-g11*oy(i,j,k,0))/(g22*g11-g12*g21) w(i,j,k,0)=(oz(i,j,k,0)-u(i,j,k,0)*g13-v(i,j,k,0)*g23)/g33 if(galu**2+galv**2.ne.0.) then u(i,j,k,0)=u(i,j,k,0)+galu v(i,j,k,0)=v(i,j,k,0)+galv ox(i,j,k,0)=g11*u(i,j,k,0)+g21*v(i,j,k,0) oy(i,j,k,0)=g12*u(i,j,k,0)+g22*v(i,j,k,0) oz(i,j,k,0)=g13*u(i,j,k,0)+g23*v(i,j,k,0)+g33*w(i,j,k,0) endif ox(i,j,k,0)=ox(i,j,k,0)+strxd(i,j) oy(i,j,k,0)=oy(i,j,k,0)+stryd(i,j) oz(i,j,k,0)=oz(i,j,k,0)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 ox(i,j,k,1)=ox(i,j,k,0) oy(i,j,k,1)=oy(i,j,k,0) oz(i,j,k,1)=oz(i,j,k,0) u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) 5 continue if(mhd.eq.1) then call bbc call noise(fbx,fby,fbz,1) do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=0. by(i,j,k,0)=0.0001*fbx(i,j,k) bz(i,j,k,0)=0. g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) by(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) bz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) pm(i,j,k)=0. fbx(i,j,k)=1. fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=1. enddo enddo enddo if (ibbl .eq. 0) then do j=1,mp do i=1,np bz(i,j,1,0) = 0. bz(i,j,2,0) = 0. bz(i,j,1,1) = 0. bz(i,j,2,1) = 0. enddo enddo endif if (ibbu .eq. 0) then do j=1,mp do i=1,np bz(i,j,l-1,0) = 0. bz(i,j,l,0) = 0. bz(i,j,l-1,1) = 0. bz(i,j,l,1) = 0. enddo enddo else do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bz(i,j,l,0) = bz(i,j,l-1,0)*(gacbt/gactp) bz(i,j,l,1) = bz(i,j,l-1,1)*(gacbt/gactp) enddo enddo endif call rhoswap( 1) !mod bbc ibbc=1 if (ibbc.eq.1) then do j=1,mp do i=1,np ! Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc endif initprst=initprs initprs=0 c call rhoswap( 1) call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp0,epp0,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,0)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,0)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,0)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) fbx(i,j,k )=0. fby(i,j,k )=0. fbz(i,j,k )=0. ccs(i,j,k)=0. enddo enddo enddo endif c if(ichm.eq.1.and.nspc.eq.5) then !lagrangian displacements c do k=1,l c do j=1,mp c do i=1,np c fchm(i,j,k,3) = u(i,j,k,0) c fchm(i,j,k,4) = v(i,j,k,0) c fchm(i,j,k,5) = w(i,j,k,0) c enddo c enddo c enddo c endif !ichm compute gallilean shift if applicable (special for translating mountains) if(galu**2+galv**2.ne.0.) then call galin(ue,galu) call galin(ve,galv) u00=u00+galu v00=v00+galv call velbc(ue,ve,rho) endif close galilean shift c call potprs(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p) c do k=1,l c do j=1,mp c do i=1,np c pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) c pfy(i,j,k)=0. c enddo c enddo c enddo c call sumcns(pfx,pfy,rho,hise(1,1),1) c hise(1,2)=0. c if(mhd.eq.1) then c ben0=0.125/pi c do k=1,l c do j=1,mp c do i=1,np c pfx(i,j,k)=bx(i,j,k,0)**2+by(i,j,k,0)**2+bz(i,j,k,0)**2 c pfx(i,j,k)=ben0*pfx(i,j,k) c enddo c enddo c enddo c call sumcnsB(pfx,hise(1,2)) c endif c---> time averaged fields, special (reinitilisation) do k=1,l do j=1-ih,mp+ih do i=1-ih,np+ih utav(i,j,k)=0. vtav(i,j,k)=0. wtav(i,j,k)=0. thtav(i,j,k)=0. ptav(i,j,k)=0. if(mhd.eq.1) then bxtav(i,j,k)=0. bytav(i,j,k)=0. bztav(i,j,k)=0. endif enddo enddo enddo if(iwrite.eq.1) then call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) endif nitsm=0 icount=0 close potential flow initialisation c---------------------------------------------------------- do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,hise(1,1),1) hise(1,2)=0. create initial advective courant numbers for eulerian integrations if(ieul.eq.1) then do k=1,l do j=1,mp do i=1,np ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) u(i,j,k,1)=0. v(i,j,k,1)=0. w(i,j,k,1)=0. ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. enddo enddo enddo c ---- determine staggered velocities and fluxes call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p,gc1,gc2,gc3,0,epp0,itp0) endif else ! irst else clause ccccccccccccccccccccccccccccccccccccccccccc c --- read history tape ccccccccccccccccccccccccccccccccccccccccccc tt0=0. ! set the initial time in secs itstart=0 ! set the initial timestep c -------------------------------------------------------- niter=0 ! don't touch these nitsm=0 icount=0 initprs=1 tt=tt0 time=tt0/timescale do 1200 kf=1,nrestr ! read stored files from 1st to nrestr icomm=max0(iwrite0,kf/nrestr) call ioread(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,icomm) if(iwrite.eq.1 .and. iwrite0.eq.1) *call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) time=time+dtfil(kf)*ntfil(kf)/timescale tt=tt+dtfil(kf)*ntfil(kf) if (mype.eq.0) print 209, itstart,kf,time,tt 1200 continue 209 format(4x,' read tape; itstrt,kf,time,tt:',2i5,f7.2,e11.4) if(iwrite.eq.1 .and. iwrite0.eq.0) *call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) ! time=tt0/timescale ! do 1201 kfo=1,nresto ! icomo=max0(iwrite0,kfo/nresto) ! call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), ! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), ! . icomo) !c call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm, !c . icomo) ! if(iwrite.eq.1 .and. iwrite0.eq.1) ! . call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), ! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) !c if(iwrite.eq.1 .and. iwrite0.eq.1) call iowrsh(u(1-ih,1-ih,1,0), !c . v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm) ! time=time+dtfilo(kfo)*ntfilo(kfo)/timescale ! if (mype.eq.0) print 2091, kfo,time ! 1201 continue ! 2091 format(4x,' read short tape; kfo, time,:',i5,f7.2) ! if(iwrite.eq.1 .and. iwrite0.eq.0) ! . call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), !! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) !c if(iwrite.eq.1 .and. iwrite0.eq.0) call iowrsh(u(1-ih,1-ih,1,0), !c . v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm) c -------------------------------------------------------- c --- initialize other fields based upon the history tape c -------------------------------------------------------- compute coordinate transformation related matrices call topolog(x,y) call metryc(x,y,z) compute base state, environmental, and absorber profiles call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif check if reference density nonnegative; if yes increase th00 call rhngck(rho) #if (MOISTMOD > 0) check if reference conditional instability may occur if(moist.eq.1) call cndinst #endif create boundary values for velocity call velbc(ue,ve,rho) c if(mhd.eq.1) call bbc c---------------------------------------------------------- c epp1=1.e-5 do 1203 k=1,l do 1203 j=1,mp do 1203 i=1,np ia = (npos-1)*np + i ja = (mpos-1)*mp + j c **** NOTE: stored "p" is actually multiplied by dt **** c c * So when dt is changed, need to premulitply read in c c * p field by ratio (new dt)/(old dt) c c **** ------- This is a ONE-TIME adjustment --------- **** c !GM p(i,j,k)=p(i,j,k)*(dt/dtfil(nrestr)) x0(i,j,k) =float(ia) y0(i,j,k) =float(ja) z0(i,j,k) =float(k) c mod-restart c ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) c oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) c oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. u(i,j,k,1)=0. v(i,j,k,1)=0. w(i,j,k,1)=0. itayler = 0 if(itayler.eq.1) then call noise(ptay,ptay,ptay) call filstr(ptay) ft(i,j,k)=ft(i,j,k) + 1.e-1*ptay(i,j,k) endif 1203 continue if(mhd.eq.1) then ibzero = 0 !GG: initializing from tape without imposing new initial field if (ibzero.eq.1) then ! do k=1,l ! do j=1,mp ! do i=1,np ! bx(i,j,k,1)=bx(i,j,k,0) ! by(i,j,k,1)=by(i,j,k,0) ! bz(i,j,k,1)=bz(i,j,k,0) ! enddo ! enddo ! enddo !! GG: initializing from tape with Bfield=0, and imposing new initial !! GG: condition ! else call noise(fbx,fby,fbz,1) do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=0. by(i,j,k,0)=0. bz(i,j,k,0)=1.e-3*fbx(i,j,k) g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) by(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) bz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) pm(i,j,k)=0. fbx(i,j,k)=0. fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=1. enddo enddo enddo !mod bbc if (ibbl .eq. 0) then do j=1,mp do i=1,np bz(i,j,1,0) = 0. bz(i,j,2,0) = 0. bz(i,j,1,1) = 0. bz(i,j,2,1) = 0. enddo enddo endif if (ibbu .eq. 0) then do j=1,mp do i=1,np bz(i,j,l-1,0) = 0. bz(i,j,l,0) = 0. bz(i,j,l-1,1) = 0. bz(i,j,l,1) = 0. enddo enddo else do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bz(i,j,l,0) = bz(i,j,l-1,0)*(gacbt/gactp) bz(i,j,l,1) = bz(i,j,l-1,1)*(gacbt/gactp) enddo enddo endif call rhoswap( 1) !mod bbc ibbc=1 if (ibbc.eq.1) then do j=1,mp do i=1,np ! Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc endif initprst=initprs initprs=0 c call rhoswap( 1) call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp0,epp0,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,0)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,0)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,0)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) fbx(i,j,k )=0. fby(i,j,k )=0. fbz(i,j,k )=0. ccs(i,j,k)=0. enddo enddo enddo endif !GG: end of condition for initialization of Bfield endif !GG: imhd clause #if (MOISTMOD > 0) do k=1,l do j=1,mp do i=1,np thf(i,j,k)=th(i,j,k)+the(i,j,k) ftf(i,j,k)=ft(i,j,k) enddo enddo enddo #endif c ---- determine staggered velocities and fluxes call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p,gc1,gc2,gc3,0,epp1,itp1) endif ! end irst if ccccccccccccccccccccccccccccccccccccccccccc c --- compute initial diagnostics and plots ccccccccccccccccccccccccccccccccccccccccccc call sumcns(th,the,rho,thsum0,0) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) oy(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) oz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) enddo enddo enddo call rhsdiv(ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1),rh0,pfz,1) do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)= 0. oy(i,j,k,1)= 0. oz(i,j,k,1)= 0. enddo enddo enddo endif #if (MOISTMOD > 0) c total water: call totwtr(qv,qc,qr,rho,qws0) c initial rainfall distribution do j=1,mp do i=1,np prec_dis(i,j)=0. enddo enddo #endif call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) if(nslice.gt.0) then call slices(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,tke,chm,qv,qc,qr,qia,qib,0) endif if(nxaver.gt.0) then call xaver(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * th,p,tau(1,1-ih,1-ih,1),0,irst) endif #if (GKS == 1) #if (PLOTPL == 1) call plot(th,u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * p,pfy,chm,qv,qc,qr,qia,qib,lipps,tke,pfz,tau(1,1-ih,1-ih,1)) #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * pfx,pfy,pfz,1) call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,pfx,pfy,pfz) #endif #endif #if (V5D == 1) inbr=0 call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) #endif close initial conditions ************************************* c************************************************************* call ttend(2) ! initial c************************************************************* compute solution in time ************************************* c------ advance a timestep do 10 it=1+itstart,nt+itstart call ttbeg(3) ! timestep c if(mype.eq.0) print *,'TIMESTEP:',it,' time',time c ------ reducing order of numerics for HF filtering if(it/mpfl*mpfl.eq.it) then liner=1 else liner=0 endif #if (SEMILAG == 1) compute semi-Lagrangian origination pts if(lagr.eq.1) call traject(ox,oy,oz,n,m,l,gc1,gc2,gc3,1) #endif c------------------------------------------------------------- c------------------------------------------------------------- compute fields + 1st half of the trapezoidal forcing do 290 k=1,l do 290 j=1,mp do 290 i=1,np ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) u(i,j,k,0)= u(i,j,k,0)+fx(i,j,k)*dth v(i,j,k,0)= v(i,j,k,0)+fy(i,j,k)*dth w(i,j,k,0)= w(i,j,k,0)+fz(i,j,k)*dth th(i,j,k) =th(i,j,k) +ft(i,j,k)*dth 290 continue if(implgw.eq.0) call pertth(th, 1) ! advect full theta call ttend(3) ! timestep c ----- advect fields for first order estimate at (n+1) call advec(th,x0,y0,z0,1,1) call advec(u(1-ih,1-ih,1,0),x0,y0,z0,2,0) if(j3.eq.1.or.icorio.eq.1) *call advec(v(1-ih,1-ih,1,0),x0,y0,z0,3,0) call advec(w(1-ih,1-ih,1,0),x0,y0,z0,4,0) c------------------------------------------------------------- if(itraj.eq.1) then ! Runge-Kutta time integration call ttbeg(3) ! timestep do 291 k=1,l do 291 j=1,mp do 291 i=1,np fox(i,j,k)=ox(i,j,k,0)+fox(i,j,k)*dth foy(i,j,k)=oy(i,j,k,0)+foy(i,j,k)*dth 291 foz(i,j,k)=oz(i,j,k,0)+foz(i,j,k)*dth call ttend(3) ! timestep call advec(fox,x0,y0,z0,51,0) call advec(foy,x0,y0,z0,52,0) call advec(foz,x0,y0,z0,53,0) endif if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=bx(i,j,k,0)+fbx(i,j,k)*dth by(i,j,k,0)=by(i,j,k,0)+fby(i,j,k)*dth bz(i,j,k,0)=bz(i,j,k,0)+fbz(i,j,k)*dth enddo enddo enddo call advec(bx(1-ih,1-ih,1,0),x0,y0,z0,31,0) call advec(by(1-ih,1-ih,1,0),x0,y0,z0,32,0) call advec(bz(1-ih,1-ih,1,0),x0,y0,z0,33,0) endif if(itke.eq.1) then call ttbeg(3) ! timestep do k=1,l do j=1,mp do i=1,np tke(i,j,k)=tke(i,j,k)+ftke(i,j,k)*dth enddo enddo enddo call ttend(3) ! timestep call advec(tke,x0,y0,z0,9,0) endif if(ichm.eq.1) then call ttbeg(3) ! timestep do ispc=1,nspc do k=1,l do j=1,mp do i=1,np chm(i,j,k,ispc)=chm(i,j,k,ispc)+fchm(i,j,k,ispc)*dth enddo enddo enddo ispca=ispc+20 call advec(chm(1-ih,1-ih,1,ispc),x0,y0,z0,ispca,0) call sumcns(chm(1-ih,1-ih,1,ispc),pfy,rho,hischm(it+1,ispc),1) enddo call ttend(3) ! timestep endif !ichm c------------------------------------------------------------- #if (MOISTMOD > 0) IF(MOIST.EQ.1) THEN call ttbeg(4) ! moist cc moist forces: ftf,fqv,fqc,fqr - condensation + absorbers cc ftfa,fqva,fqca,fqra - precipitation ccc get fields and condensation forces at the departure point: call advec(thf,x0,y0,z0,11,0) call advec( qv,x0,y0,z0,6,0) call advec( qc,x0,y0,z0,7,0) call advec( qr,x0,y0,z0,8,0) call advec(ftf,x0,y0,z0,12,0) call advec(fqv,x0,y0,z0,12,0) call advec(fqc,x0,y0,z0,12,0) call advec(fqr,x0,y0,z0,12,0) do k=1,l do j=1,mp do i=1,np ftfa(i,j,k)=ftf(i,j,k) fqva(i,j,k)=fqv(i,j,k) fqca(i,j,k)=fqc(i,j,k) fqra(i,j,k)=fqr(i,j,k) enddo enddo enddo cc routine precip proceeds with small time step in columns cc with condensate; estimates of sources due to precip cc processes are brought back in ftfa, fqva, etc. call precip(thf,qv,qc,qr,ftfa,fqva,fqca,fqra,n,m,l,ndtm,dtm,it) cc routine adj_prec completes model time step for thermodynamic cc fields using averged tendencies brought back from precip and cc departure point values of model fields; cc NOTE: mean temperature tendency due to precipitation is brought back cc in ftfa to be applied to th after condensation call adj_prec(thf,qv,qc,qr,ftf,fqv,fqc,fqr, . ftfa,fqva,fqca,fqra,n,m,l) call ttend(4) ! moist ENDIF #endif /* MOISTMOD > 0 */ close 1st half of the trapezoidal forcing c------------------------------------------------------------- c------------------------------------------------------------- compute time dependent metric terms and related quantities tt=tt+dt time=tt/timescale if(tt.le.tend) then call ttbeg(5) ! timedtransf #if (SEMILAG == 0) if(lagr.eq.0) then c --- calls to rhotad correct anelastic mpdata to full c --- 2nd order time accuracy with time variable density call rhotad(th,rho, 1) call rhotad(u(1-ih,1-ih,1,0),rho, 1) call rhotad(v(1-ih,1-ih,1,0),rho, 1) call rhotad(w(1-ih,1-ih,1,0),rho, 1) if(mhd.eq.1) then call rhotad(bx(1-ih,1-ih,1,0),rho, 1) call rhotad(by(1-ih,1-ih,1,0),rho, 1) call rhotad(bz(1-ih,1-ih,1,0),rho, 1) endif #if (MOISTMOD > 0) call rhotad(thf,rho, 1) call rhotad( qv,rho, 1) call rhotad( qc,rho, 1) call rhotad( qr,rho, 1) #endif endif #endif compute coordinate transformation related matrices call topolog(x,y) c call shallow(it,rho,x,y) call metryc(x,y,z) compute base state, environmental, and absorber profiles !GG call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif create boundary values for velocity call velbc(ue,ve,rho) c if(mhd.eq.1) call bbc #if (SEMILAG == 0) if(lagr.eq.0) then call rhotad(th,rho,-1) call rhotad(u(1-ih,1-ih,1,0),rho,-1) call rhotad(v(1-ih,1-ih,1,0),rho,-1) call rhotad(w(1-ih,1-ih,1,0),rho,-1) if(mhd.eq.1) then call rhotad(bx(1-ih,1-ih,1,0),rho,-1) call rhotad(by(1-ih,1-ih,1,0),rho,-1) call rhotad(bz(1-ih,1-ih,1,0),rho,-1) endif #if (MOISTMOD > 0) call rhotad(thf,rho,-1) call rhotad( qv,rho,-1) call rhotad( qc,rho,-1) call rhotad( qr,rho,-1) #endif endif #endif call ttend(5) ! timetransf endif close time dependent metrics c------------------------------------------------------------- c 1 2 3 4 5 6 7 c123456789012345678901234567890123456789012345678901234567890123456789012 c------------------------------------------------------------- call ttbeg(3) ! timestep if(implgw.eq.0) call pertth(th,-1) ! return to theta perturbation COMPUTE SPECIAL PROFILES FOR GW ABSORBERS c--------> special zonal averages for GW absorbers izonal=0 if(izonal.eq.1) then call zonav(u(1-ih,1-ih,1,0),uza,tau(1,1-ih,1-ih,1),1) call zonav(v(1-ih,1-ih,1,0),vza,tau(1,1-ih,1-ih,1),1) call zonav(w(1-ih,1-ih,1,0),wza,tau(1,1-ih,1-ih,1),1) call zonav(th,thza,tau(1,1-ih,1-ih,2),1) if(mhd.eq.1) then call zonav(bx(1-ih,1-ih,1,0),bxza,tau(1,1-ih,1-ih,1),1) call zonav(by(1-ih,1-ih,1,0),byza,tau(1,1-ih,1-ih,1),1) call zonav(bz(1-ih,1-ih,1,0),bzza,tau(1,1-ih,1-ih,1),1) endif if(moist.eq.1) call zonav(qv,qvza,tau(1,1-ih,1-ih,2),1) end if c------------------------------------------------------------- call ttend(3) ! timestep #if (MOISTMOD > 0) call ttbeg(4) ! moist cc finalize thermodynamics with condensation at the arrival point: call cond(thf,qv,qc,qr,ftf,fqv,fqc,fqr,tau(1,1-ih,1-ih,2)) cc apply forces to the model temperature do k=1,l do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+dth*(ftf(i,j,k)+2.*ftfa(i,j,k)) enddo enddo enddo call totwtr(qv,qc,qr,rho,qws) totw(it)=qws*dx*dy*dz call ttend(4) ! moist #endif c------------------------------------------------------------- c------------------------------------------------------------- c------ add new buoyancy, coriolis, metric and absorber forces c-------into auxiliary velocities (at grid points) if(intz.eq.1.and.igrid.eq.0) then do k=1,l do j=1,mp do i=1,np bu(i,j,k)=th(i,j,k) enddo enddo enddo call integz(bu,fy) endif do 292 mtri=1,mtrimx !outer iterations (for quadratic terms) if(mhd.eq.1) then if(mtrord.eq.2) then if(isphere.eq.1) then do k=1,l do j=1,mp do i=1,np gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,1) & -bx(i,j,k,1)*v(i,j,k,1)) & + bx(i,j,k,1)*w(i,j,k,1) - bz(i,j,k,1)*u(i,j,k,1)) ifrm2 = gmri*(by(i,j,k,1)*w(i,j,k,1)-bz(i,j,k,1)*v(i,j,k,1)) ifrm3=0. bx(i,j,k,1)=bx(i,j,k,0)+dth*ifrm1 by(i,j,k,1)=by(i,j,k,0)+dth*ifrm2 c bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm1 bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm3 !mod new enddo enddo enddo else do k=1,l do j=1,mp do i=1,np bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) enddo enddo enddo endif call rBVi(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) & ,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),w(1-ih,1-ih,1,1)) call rBB(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), & rho,bfx,bfy,bfz,xmiui) endif endif call ttbeg(3) ! timestep do 295 k=1,l ! compute forcings due to absorbers do 295 j=1,mp ! and spherical Christoffel symbols do 295 i=1,np uexpl=u(i,j,k,0) vexpl=v(i,j,k,0) wexpl=w(i,j,k,0) if(mtrord.eq.2 .and. (isphere.eq.1.or.icylind.eq.1)) then if( isphere.eq.1) then if(mhd.eq.1) then we=0. gmri=1./(gmm(i,j,k)*rds) lfrm1= gmri*( & -tnga(i,j)*(bx(i,j,k,1)*by(i,j,k,1)-bxe(i,j,k)*bye(i,j,k)) & +(bx(i,j,k,1)*bz(i,j,k,1)-bxe(i,j,k)*bze(i,j,k)) ) lfrm2= gmri*( & tnga(i,j)*(bx(i,j,k,1)*bx(i,j,k,1)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,1)*bz(i,j,k,1)-bye(i,j,k)*bze(i,j,k)) ) lfrm3=-gmri*( (bx(i,j,k,1)*bx(i,j,k,1)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,1)*by(i,j,k,1)-bye(i,j,k)*bye(i,j,k)) ) bfx(i,j,k)=bfx(i,j,k)+lfrm1*xmiui*rh0(i,j,k)/rho(i,j,k) bfy(i,j,k)=bfy(i,j,k)+lfrm2*xmiui*rh0(i,j,k)/rho(i,j,k) bfz(i,j,k)=bfz(i,j,k)+lfrm3*xmiui*rh0(i,j,k)/rho(i,j,k) endif gmri=1./(gmm(i,j,k)*rds) frm1= gmri*tnga(i,j)*(u(i,j,k,1)*v(i,j,k,1)-ue(i,j,k)*ve(i,j,k)) . -gmri*(u(i,j,k,1)*w(i,j,k,1)) frm2=-gmri*tnga(i,j)*(u(i,j,k,1)*u(i,j,k,1)-ue(i,j,k)*ue(i,j,k)) . -gmri*(v(i,j,k,1)*w(i,j,k,1)) frm3= gmri* ( (u(i,j,k,1)*u(i,j,k,1)-ue(i,j,k)*ue(i,j,k)) 1 +(v(i,j,k,1)*v(i,j,k,1)-ve(i,j,k)*ve(i,j,k)) ) else gmri=1./gmm(i,j,k) frm1= gmri*(v(i,j,k,1)*v(i,j,k,1)-ve(i,j,k)*ve(i,j,k)) frm2=-gmri*(u(i,j,k,1)*v(i,j,k,1)-ue(i,j,k)*ve(i,j,k)) frm3=0. endif if(mhd.eq.1) then uexpl= uexpl+dth*bfx(i,j,k) vexpl= vexpl+dth*bfy(i,j,k) wexpl= wexpl+dth*bfz(i,j,k) endif uexpl=uexpl+dth*frm1 vexpl=vexpl+dth*frm2 wexpl=wexpl+dth*frm3 C original code commented out to accomodate mihai change to bypass C mhd=1 icylind=1 compare with sun_mhdN.src c uexpl=u(i,j,k,0)+dth*frm1 c vexpl=v(i,j,k,0)+dth*frm2 c wexpl=w(i,j,k,0)+dth*frm3 c else c uexpl=u(i,j,k,0) c vexpl=v(i,j,k,0) c wexpl=w(i,j,k,0) endif if(mtri.eq.mtrimx) then u(i,j,k,0)=uexpl v(i,j,k,0)=vexpl w(i,j,k,0)=wexpl endif c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) c astrt=dth*(tau(k,i,j,2)*(1.-relt)+relt) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astrt=dth*(tau(k,i,j,2)**2+relt**2) & /(tau(k,i,j,2)+relt+1.e-13) astri =1./(1.+astr ) astrti=1./(1.+astrt) f2str=dth*fcr2(i,j) f3str=dth*fcr3(i,j) c density stratified, th means rho !incompress Euler ! rhoinc=th(i,j,k)+the(i,j,k) !--------------------------------------- ! Anelastic/Boussinesq in theta rhoinc=-th0(i,j,k) !--------------------------------------- ! Boussinesq in rho c rhoinc=rh00 ! Gmod =-dth*g/rhoinc*astri ! & /gmm(i,j,k)**2 !Sun ! Gmodt=-dth*g/rhoinc*astrti ! & /gmm(i,j,k)**2 !Sun Gmod =-dth/rhoinc*astri & *(3694.34945199-1.26840190398e-05*rds*gmm(i,j,k) & +1.65029739402e-14*(rds*gmm(i,j,k))**2 & -7.67624479849e-24*(rds*gmm(i,j,k))**3) ! Rafaella, sun Gmodt=-dth/rhoinc*astrti & *(3694.34945199-1.26840190398e-05*rds*gmm(i,j,k) & +1.65029739402e-14*(rds*gmm(i,j,k))**2 & -7.67624479849e-24*(rds*gmm(i,j,k))**3) ! Rafaella, sun Rt=(1.+astrt)*astri we=0. ustr=uexpl+ astr*ue(i,j,k)-f3str*ve(i,j,k) +f2str*we vstr=vexpl+ astr*ve(i,j,k)+f3str*ue(i,j,k) if(intz.eq.1.and.igrid.eq.0) then wstr=wexpl+Gmodt*bu(i,j,k)-f2str*ue(i,j,k) + astr*we else wstr=wexpl+Gmodt*th(i,j,k)-f2str*ue(i,j,k) + astr*we endif if(izonal.eq.1) then c------> special damp to zonal averages (implicit GW absorption) ustr=ustr+ astr*(uza(j,k)-ue(i,j,k)) vstr=vstr+ astr*(vza(j,k)-ve(i,j,k)) wstr=wstr+Gmodt*astrt*thza(j,k)+astr*(wza(j,k)-we) end if #if (MOISTMOD > 0) wstr=wstr+Gmodt*th0(i,j,k)*(epsb*(qv(i,j,k)-qve(i,j,k)) . -(qc(i,j,k)+ qr(i,j,k))) #endif F2str=f2str*astri F3str=f3str*astri niu1= (Rt+Gmod*dthe(i,j,k,3))*ustr - Rt*F2str*wstr .+(Rt*F3str+Gmod*(F2str*dthe(i,j,k,2)+F3str*dthe(i,j,k,3)))*vstr niu2=-F3str*(Rt+Gmod*dthe(i,j,k,3))*ustr + Rt*F2str*F3str*wstr .+(Rt*(1.+F2str**2)+Gmod*(-F2str*dthe(i,j,k,1)+dthe(i,j,k,3)))*vstr niu3= (Rt*F2str+Gmod*(-dthe(i,j,k,1)+F3str*dthe(i,j,k,2)))*ustr . +(Rt*F2str*F3str-Gmod*(F3str*dthe(i,j,k,1)+dthe(i,j,k,2)))*vstr . +Rt*(1.+F3str*F3str)*wstr G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,1)= G11*niu1 + G21*niu2 oy(i,j,k,1)= G12*niu1 + G22*niu2 oz(i,j,k,1)= G13*niu1 + G23*niu2 + G33*niu3 c incompress Euler c ox(i,j,k,1)=ox(i,j,k,1)*rhoinc c oy(i,j,k,1)=oy(i,j,k,1)*rhoinc c oz(i,j,k,1)=oz(i,j,k,1)*rhoinc etainv=( -Gmod*dthe(i,j,k,1)*F2str . +Gmod*dthe(i,j,k,2)*F2str*F3str . +Gmod*dthe(i,j,k,3)*(1.+F3str*F3str) . +Rt*(1.+F2str*F2str+F3str*F3str) )*(1.+astr) c incompress Euler c . *rhoinc fx(i,j,k)=astri fy(i,j,k)=Gmod fz(i,j,k)=1./etainv ft(i,j,k)=Rt 295 continue call ttend(3) ! timestep compute pressure equation c here fx,fy,fz and ft contain coefficients defined in 295; c we still need u0,v0,w0,t0 for new forces c upon return, pfx, pfy, and pfz contain updated solenoidal vel''s mtrf=mtri-1 call gcrk(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,1), . oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1), . fx,fy,fz,ft,ub,vb,ob,itp1,epp1,mtrf,1) !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'gcrk=',mtri,mtrimx,inbr ! call vis5d_out(pfx,pfy,pfz,pfz,pfz,ft, ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif call prforc(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,1), . oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1),fx,fy,fz,ft,ub,vb,ob,1) !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'prfo=',mtri,mtrimx,inbr ! call vis5d_out(pfx,pfy,pfz,pfz,pfz,ft, ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif call ttbeg(3) ! timestep compute velocity and forces'' update, and shift temporal levels do 34 k=1,l do 34 j=1,mp do 34 i=1,np G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) c --- store updated solenoidal velocity at time level n ox(i,j,k,1)=pfx(i,j,k) oy(i,j,k,1)=pfy(i,j,k) oz(i,j,k,1)=pfz(i,j,k) c --- compute updated physical velocity at time level n u(i,j,k,1)= (G22*ox(i,j,k,1)-G21*oy(i,j,k,1))/(G22*G11-G12*G21) v(i,j,k,1)=-(G12*ox(i,j,k,1)-G11*oy(i,j,k,1))/(G22*G11-G12*G21) w(i,j,k,1)=(oz(i,j,k,1)-G13*u(i,j,k,1)-G23*v(i,j,k,1))/G33 IF(mtri.eq.mtrimx) THEN ! if last outer loop, then ... fz(i,j,k) =th(i,j,k) c---- absorbing to zonal averages if(izonal.eq.1) + fz(i,j,k) =fz(i,j,k)+thza(j,k)*(ft(i,j,k)/fx(i,j,k)-1.) c --- compute updated tendencies fy(i,j,k) = u(i,j,k,1)*dthe(i,j,k,1) . +v(i,j,k,1)*dthe(i,j,k,2) . +w(i,j,k,1)*dthe(i,j,k,3) c th(i,j,k)=( fz(i,j,k)*fx(i,j,k)-fy(i,j,k) )/ft(i,j,k) c ft(i,j,k)=( th(i,j,k)-fz(i,j,k) )*2.*dti fz(i,j,k)=( fz(i,j,k)*fx(i,j,k)-fy(i,j,k) )/ft(i,j,k) !mod Andii new th ft(i,j,k)=( fz(i,j,k)-th(i,j,k) )*2.*dti !new forcing th(i,j,k)=fz(i,j,k) fx(i,j,k)=( u(i,j,k,1)-u(i,j,k,0) )*2.*dti fy(i,j,k)=( v(i,j,k,1)-v(i,j,k,0) )*2.*dti fz(i,j,k)=( w(i,j,k,1)-w(i,j,k,0) )*2.*dti c --- store updated physical velocity at time level n u(i,j,k,0)= u(i,j,k,1) v(i,j,k,0)= v(i,j,k,1) w(i,j,k,0)= w(i,j,k,1) c --- compute updated advective velocity at time level n pfx(i,j,k)=ox(i,j,k,1)+strxd(i,j) pfy(i,j,k)=oy(i,j,k,1)+stryd(i,j) pfz(i,j,k)=oz(i,j,k,1)-gmul(k)*zsd(i,j)/zb*G33 . +(gmul(k)/zb-1.)*zhd(i,j)*G33 c --- reinitialize arrays ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. u(i,j,k,1)= 0. v(i,j,k,1)= 0. w(i,j,k,1)= 0. c --- store updated advective velocity at time level n ox(i,j,k,0)=pfx(i,j,k) oy(i,j,k,0)=pfy(i,j,k) oz(i,j,k,0)=pfz(i,j,k) c --- Runge-Kutta force update if(itraj.eq.1) then fox(i,j,k)=( ox(i,j,k,0)-fox(i,j,k) )*2.*dti foy(i,j,k)=( oy(i,j,k,0)-foy(i,j,k) )*2.*dti foz(i,j,k)=( oz(i,j,k,0)-foz(i,j,k) )*2.*dti endif ENDIF 34 continue IF(mhd.eq.1) THEN lc=1 if(mtri.eq.mtrimx) lc=0 if(mtrord.eq.2) then if(isphere.eq.1) then do k=1,l do j=1,mp do i=1,np gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,lc) & -bx(i,j,k,1)*v(i,j,k,lc)) & + bx(i,j,k,1)*w(i,j,k,lc) - bz(i,j,k,1)*u(i,j,k,lc)) ifrm2=gmri*(by(i,j,k,1)*w(i,j,k,lc)-bz(i,j,k,1)*v(i,j,k,lc)) ifrm3=0. bx(i,j,k,1)=bx(i,j,k,0)+dth*ifrm1 by(i,j,k,1)=by(i,j,k,0)+dth*ifrm2 c bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm1 bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm3 !mod new enddo enddo enddo else do k=1,l do j=1,mp do i=1,np bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) enddo enddo enddo endif endif call rBVi(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) & ,u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc)) c call rBVeO(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) !default c & ,u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc), !default c & fbx,fby,fbz) !default call rBVeN(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), !option & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), !option & u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc), !option & fbx,fby,fbz,1) !option do 2951 k=1,l ! compute forcings due to absorbers do 2951 j=1,mp ! and spherical Christoffel symbols do 2951 i=1,np if(mtrord.eq.2) then if(isphere.eq.1) then we=0. gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,lc) & -bx(i,j,k,1)*v(i,j,k,lc)) & + bx(i,j,k,1)*w(i,j,k,lc) - bz(i,j,k,1)*u(i,j,k,lc)) ifrm2=gmri*(by(i,j,k,1)*w(i,j,k,lc)-bz(i,j,k,1)*v(i,j,k,lc)) ifrm3=0. fbx(i,j,k)=fbx(i,j,k)+ifrm1 fby(i,j,k)=fby(i,j,k)+ifrm2 fbz(i,j,k)=fbz(i,j,k)+ifrm3 endif bxxpl=bx(i,j,k,0)+dth*fbx(i,j,k) byxpl=by(i,j,k,0)+dth*fby(i,j,k) bzxpl=bz(i,j,k,0)+dth*fbz(i,j,k) else bxxpl=bx(i,j,k,1) byxpl=by(i,j,k,1) bzxpl=bz(i,j,k,1) endif if(mtri.eq.mtrimx) then bx(i,j,k,0)=bxxpl by(i,j,k,0)=byxpl bz(i,j,k,0)=bzxpl endif c------> damp to environmental profiles idmpep=0 if(idmpep.eq.1) then bxstr=bxxpl+ astr*bxe(i,j,k)*iabb bystr=byxpl+ astr*bye(i,j,k)*iabb bzstr=bzxpl+ astr*bze(i,j,k)*iabb end if if(izonal.eq.1) then bxstr=bxstr+ astr*(bxza(j,k)-bxe(i,j,k))*iabb bystr=bystr+ astr*(byza(j,k)-bye(i,j,k))*iabb bzstr=bzstr+ astr*(bzza(j,k)-bze(i,j,k))*iabb end if c------> end of damping to zonal averages c------> damp bx and by to 0 at the top boundary c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) !new c astrt =dth*(tau(k,i,j,2)*(1.-relt)+relt) !new c astrti =1./(1.+astrt ) !new bxstr=bxxpl*(1.-tau(k,i,j,2)*iabb) bystr=byxpl*(1.-tau(k,i,j,2)*iabb) bzstr=bzxpl G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bxstr+G21*bystr by(i,j,k,1)= G12*bxstr+G22*bystr bz(i,j,k,1)= G13*bxstr+G23*bystr+G33*bzstr c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) !new c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) !new c astri =1./(1.+astr ) !new relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astrt=dth*(tau(k,i,j,2)**2+relt**2) & /(tau(k,i,j,2)+relt+1.e-13) fbx(i,j,k)=astri*iabb+float(1-iabb) fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=astri*iabb+float(1-iabb) 2951 continue idvcln=1 if(idvcln.eq.1) then initprst=initprs initprs=0 !mod bbc ibbc=1 if(ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc else call rhoswap( 1) endif call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp1,epp1,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst else do k=1,l do j=1,mp do i=1,np bfx(i,j,k)=bx(i,j,k,1) bfy(i,j,k)=by(i,j,k,1) bfz(i,j,k)=bz(i,j,k,1) enddo enddo enddo endif do 341 k=1,l do 341 j=1,mp do 341 i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,1)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,1)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,1)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 IF(mtri.eq.mtrimx) THEN ! if last outer loop, then ... fbx(i,j,k)=(bx(i,j,k,1)-bx(i,j,k,0))*2.*dti fby(i,j,k)=(by(i,j,k,1)-by(i,j,k,0))*2.*dti fbz(i,j,k)=(bz(i,j,k,1)-bz(i,j,k,0))*2.*dti bx(i,j,k,0)=bx(i,j,k,1) by(i,j,k,0)=by(i,j,k,1) bz(i,j,k,0)=bz(i,j,k,1) ENDIF 341 continue ENDIF call ttend(3) ! timestep 292 continue ! end outer iterations c------------------------------------------------------------- call ttbeg(3) ! timestep if(isphere.eq.1) then compute metric forces do 36 k=1,l do 36 j=1,mp do 36 i=1,np gmri=1./(gmm(i,j,k)*rds) frm1= gmri*tnga(i,j)*(u(i,j,k,0)*v(i,j,k,0)-ue(i,j,k)*ve(i,j,k)) . -gmri*(u(i,j,k,0)*w(i,j,k,0)) frm2=-gmri*tnga(i,j)*(u(i,j,k,0)*u(i,j,k,0)-ue(i,j,k)*ue(i,j,k)) . -gmri*(v(i,j,k,0)*w(i,j,k,0)) frm3= gmri* ( (u(i,j,k,0)*u(i,j,k,0)-ue(i,j,k)*ue(i,j,k)) 1 +(v(i,j,k,0)*v(i,j,k,0)-ve(i,j,k)*ve(i,j,k)) ) fx(i,j,k)=fx(i,j,k)+(3-mtrord)*frm1 fy(i,j,k)=fy(i,j,k)+(3-mtrord)*frm2 36 fz(i,j,k)=fz(i,j,k)+(3-mtrord)*frm3 endif if(icylind.eq.1) then do 336 k=1,l do 336 j=1,mp do 336 i=1,np gmri=1./gmm(i,j,k) frm1= gmri*(v(i,j,k,0)*v(i,j,k,0)-ve(i,j,k)*ve(i,j,k)) frm2=-gmri*(u(i,j,k,0)*v(i,j,k,0)-ue(i,j,k)*ve(i,j,k)) frm3=0. fx(i,j,k)=fx(i,j,k)+(3-mtrord)*frm1 fy(i,j,k)=fy(i,j,k)+(3-mtrord)*frm2 336 fz(i,j,k)=fz(i,j,k)+(3-mtrord)*frm3 endif if(mhd.eq.1) then !compute Lorentz force call rBB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), & rho,bfx,bfy,bfz,xmiui) !compute additional metric terms for Lorentz force mg 04.05.2005 do k=1,l do j=1,mp do i=1,np if(isphere.eq.1) then gmri=1./(gmm(i,j,k)*rds) lfrm1= gmri*( & -tnga(i,j)*(bx(i,j,k,0)*by(i,j,k,0)-bxe(i,j,k)*bye(i,j,k)) & +(bx(i,j,k,0)*bz(i,j,k,0)-bxe(i,j,k)*bze(i,j,k)) ) lfrm2= gmri*( & tnga(i,j)*(bx(i,j,k,0)*bx(i,j,k,0)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,0)*bz(i,j,k,0)-bye(i,j,k)*bze(i,j,k)) ) lfrm3=-gmri*( (bx(i,j,k,0)*bx(i,j,k,0)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,0)*by(i,j,k,0)-bye(i,j,k)*bye(i,j,k)) ) bfx(i,j,k)=bfx(i,j,k)+lfrm1*xmiui*rh0(i,j,k)/rho(i,j,k) bfy(i,j,k)=bfy(i,j,k)+lfrm2*xmiui*rh0(i,j,k)/rho(i,j,k) bfz(i,j,k)=bfz(i,j,k)+lfrm3*xmiui*rh0(i,j,k)/rho(i,j,k) endif fx(i,j,k)=fx(i,j,k)+(3-mtrord)*bfx(i,j,k) fy(i,j,k)=fy(i,j,k)+(3-mtrord)*bfy(i,j,k) fz(i,j,k)=fz(i,j,k)+(3-mtrord)*bfz(i,j,k) end do end do end do !compute rhs of the induction equation c call rBVeO(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0) !option c & ,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), !option c & bfx,bfy,bfz) !option call rBVeN(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), !default & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), !default & u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), !default & bfx,bfy,bfz,0) do k=1,l do j=1,mp do i=1,np if(isphere.eq.1) then gmri=1./(gmm(i,j,k)*rds) ifrm1 = gmri*(tnga(i,j)*(by(i,j,k,0)*u(i,j,k,0) & - bx(i,j,k,0)*v(i,j,k,0)) & + bx(i,j,k,0)*w(i,j,k,0) - bz(i,j,k,0)*u(i,j,k,0)) ifrm2 = gmri*(by(i,j,k,0)*w(i,j,k,0)-bz(i,j,k,0)*v(i,j,k,0)) ifrm3=0. bfx(i,j,k)=bfx(i,j,k)+ifrm1 bfy(i,j,k)=bfy(i,j,k)+ifrm2 bfz(i,j,k)=bfz(i,j,k)+ifrm3 endif fbx(i,j,k)=fbx(i,j,k)+(3-mtrord)*bfx(i,j,k) fby(i,j,k)=fby(i,j,k)+(3-mtrord)*bfy(i,j,k) fbz(i,j,k)=fbz(i,j,k)+(3-mtrord)*bfz(i,j,k) ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. end do end do end do endif call ttend(3) ! timestep c------------------------------------------------------------- #if (MOISTMOD > 0) call ttbeg(4) ! moist if(moist.eq.1) then if(it/noutp*noutp.eq.it) then xnorf=1./float(l*m*n) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=th(i,j,k)+the(i,j,k)-thf(i,j,k) enddo enddo enddo dftmx=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftmn=globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftav=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftav=dftav*xnorf do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(th(i,j,k)+the(i,j,k)-thf(i,j,k)-dftav)**2 enddo enddo enddo dftsd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftsd=sqrt(dftsd*xnorf) endif do 37 k=1,l do 37 j=1,mp do 37 i=1,np ft(i,j,k)=ft(i,j,k)+ftf(i,j,k) ftf(i,j,k)=ft(i,j,k) 37 thf(i,j,k)=th(i,j,k)+the(i,j,k) endif call ttend(4) ! moist #endif !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'fxfy=',mtri,mtrimx,inbr ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif c------------------------------------------------------------- #if (SGS == 1) if(ivis.ne.0) then itstr=it call dissip(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), 1 th, chm, qv, qc, qr, tke, 1 fx,fy,fz,ft, fchm, qia,qib,fqia,fqib, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 u(1-ih,1-ih,1,1), v(1-ih,1-ih,1,1), w(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) endif #endif #if (SGS == 2) if(ivis.ne.0) then itstr=it call dissip(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), 1 u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), 1 th,qv,qc,qr,tke,fx,fy,fz,ft, 3 fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz, 3 u(1-ih,1-ih,1,1), v(1-ih,1-ih,1,1), w(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) idisb=1 if(mhd.eq.1.and.idisb.eq.1) then call rhoswap( 1) call dissipB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), 1 bz(1-ih,1-ih,1,0),tke,fbx,fby,fbz,bfx,bfy,bfz, 3 bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) call rhoswap(-1) endif endif #endif c------------------------------------------------------------- call ttbeg(3) ! timestep iblatt=0 if(iblatt.eq.1) then C boundary layer forcing hscl= 1.*dz tscl=500. do k=1,l zatt=2.*exp(-(k-1)*dz/hscl) do j=1,mp do i=1,np ft(i,j,k)=ft(i,j,k)+(zatt/hscl)*hfx(i,j) c fx(i,j,k)=fx(i,j,k)-(zatt/tscl)* u(i,j,k,0) c fy(i,j,k)=fy(i,j,k)-(zatt/tscl)* v(i,j,k,0) enddo enddo enddo endif c ---- held-suarez test ihs=0 if(ihs.eq.1) then do 38 k=1,l do 38 j=1,mp do 38 i=1,np dfv2=2.* hskf*dfhs(i,j,k) ! velocity boundary-layer damping dft2=2.*(hska+(hsks-hska)*dfhs(i,j,k)*cosa(i,j)**4) !theta damp. thtot=th(i,j,k)+the(i,j,k) fx(i,j,k)=fx(i,j,k)-dfv2* u(i,j,k,0) fy(i,j,k)=fy(i,j,k)-dfv2* v(i,j,k,0) fz(i,j,k)=fz(i,j,k)-dfv2* w(i,j,k,0) c --- using full HS env. theta for forcing ft(i,j,k)=ft(i,j,k)-dft2*(thtot-theq(i,j,k)) 38 continue #if (MOISTMOD > 0) if(moist.eq.1) then do 39 k=1,l do 39 j=1,mp do 39 i=1,np dft2=2.*(hska+(hsks-hska)*dfhs(i,j,k)*cosa(i,j)**4) fqv(i,j,k)=fqv(i,j,k)-dft2*(qv(i,j,k)-qveq(i,j,k)) 39 ftf(i,j,k)=ft(i,j,k) endif #endif endif c------------------------------------------------------------- isolat=1 if(isolat.eq.1) then c ---- solar forcing c tsclh=3600.*24.*30.*5. !time scale for HS forcing, 5 Sdays c tsclh=3600.*24.*30.*10. !time scale for HS forcing, 20 Sdays c tsclh=3600.*24.*30.*16. !time scale for HS forcing, 20 Sdays c tsclh=3600.*24.*30.*20. !time scale for HS forcing, 20 Sdays tsclh=3600.*24.*30.*40. !sun tshear=3600.*24*365.*2. ! 2 yr shear timescale ! call rhprof(tim,zcr,l,lipps) ! do k=1,l ! tim(k)=tsclh*tim(k)**(0.5) ! enddo tscli=1./tsclh do k=1,l do j=1,mp do i=1,np C renom= (stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) C + / (gmm(i,j,k)**2*cosa(i,j)) C rhop=rho(i,j,k)*(gi(i,j)*gmus(k))*renom C fctr=(rh00*tt00/(rhop*th0(i,j,k)))**wykl C ft(i,j,k)=ft(i,j,k) C . +2.*cnsh*fctr*(hflx(k+1)-hflx(k)) C . *(rho(i,j,1)/rho(i,j,k)) c ft(i,j,k)=ft(i,j,k)-2.*tscli*(th(i,j,k)-the(i,j,k)) !held-suarez forcing ft(i,j,k)=ft(i,j,k)-2.*tscli*th(i,j,k) !held-suarez forcing fx(i,j,k)=fx(i,j,k)-2.*(u(i,j,k,0)-u0_char(i,j,k))/tshear !Miesch Forcing enddo enddo enddo !if(mype.eq.0) print*, "u0_char=", u0_char(10, 10, 60), "Values" endif c------------------------------------------------------------- c special EXPLICIT polar damping c --- see definition of relpol in subroutine absorber c --- define special explicit absorber parameters in blanelas if(ipolar.eq.1) then call zonav(u(1-ih,1-ih,1,0),uza,tau(1,1-ih,1-ih,1),1) call zonav(v(1-ih,1-ih,1,0),vza,tau(1,1-ih,1-ih,1),1) call zonav(w(1-ih,1-ih,1,0),wza,tau(1,1-ih,1-ih,1),1) if(iabth.eq.1) . call zonav(th,thza,tau(1,1-ih,1-ih,2),1) do k=1,l do j=1,mp do i=1,np yatt=amax1(0.,2.*relpol(i,j,k)) ! additive c yatt=amax1(0.,2.*relpol(i,j)) ! additive c yatt=amax1(0.,2.*(relpol(i,j)-irly*rely(i,j))) ! nonadditive c yatt=(tau(k,i,j,1)**2+yatt**2)/(tau(k,i,j,1)+yatt+1.e-13) fx(i,j,k)=fx(i,j,k)+yatt*(uza(j,k)-u(i,j,k,0)) fy(i,j,k)=fy(i,j,k)+yatt*(vza(j,k)-v(i,j,k,0)) fz(i,j,k)=fz(i,j,k)+yatt*(wza(j,k)-w(i,j,k,0)) if(iabth.eq.1) . ft(i,j,k)=ft(i,j,k)+yatt*(thza(j,k)-th(i,j,k)) enddo enddo enddo endif c------------------------------------------------------------- call ttend(3) ! timestep compute velocity predictor for the first guess of the trajectory scheme call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p, * gc1,gc2,gc3,itraj,epp1,itp1) 1001 continue call ttbeg(3) ! timestep c --- calculate drag force ------------------------ itd=it if(idrag.eq.1) then call drag(p,dragx,dragy,n,m,L) do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,hise(it+1,1),1) hise(it+1,2)=0. endif if(mhd.eq.1) then ben0=0.125/pi do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=bx(i,j,k,0)**2+by(i,j,k,0)**2+bz(i,j,k,0)**2 pfx(i,j,k)=ben0*pfx(i,j,k) enddo enddo enddo call sumcnsB(pfx,hise(it+1,2)) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute diagnostics and output fields ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call lipsch(ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), . rho,gc1,gc2,gc3,cr1,cr2,lagr,0) call courB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), . rho,xmiu,crb,0) c epp1=amax1(1.e-6, 1.e-4*amin1(cr1,cr2)) C epp1=amax1(1.e-6, 1.e-4*cr1) epp1=amax1(1.e-5, 1.e-3*cr1) call ttend(3) ! timestep ! GG slices and xaverages output if(nslice.gt.0) then if((it-itstart)/nslice*nslice.eq.(it-itstart)) *call slices(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,tke,chm,qv,qc,qr,qia,qib,it) endif if(nxaver.gt.0) then if((it-itstart)/nxaver*nxaver.eq.(it-itstart)) then call xaver(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * th,p,tau(1,1-ih,1-ih,1),it,irst) if(mype.eq.0) print*, "it=", it, "computing zonal averages" endif endif ! ! GG if(iwrite.eq.1.and.(it-itstart)/nplot*nplot.eq.(it-itstart)) then call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) endif !GM:Condition to initiate the bridge !print *, 'EULAG - BEFORE CALL SEND' if(iwrite.eq.1.and.(it-itstart)/nbridge*nbridge.eq.(it-itstart)) . then if(tag_frn>0) . call bridge_velo_send(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0)) endif ! print *, 'Eulag Barrier' ! call MPI_BARRIER(MPI_COMM_WORLD, ierr) ! ! call MPI_FINALIZE(ierr) ! stop if(iwrite.eq.1.and. . (it-itstart)/nstore*nstore.eq.(it-itstart)) then if(it.eq.nt) ihis=1 call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,ihis) ! GG: here a new output file is written with the numer of steps ! GG: stored in the history tape ipulse = ipulse+1 if(mype.eq.0) then print*, 'NUMBER FILES IN TAPE=',ipulse open(21,file="pulses.dat",form='formatted') write(21,'(i5)'), ipulse close(21) endif ! GG endif itav=0 if (itav.eq.1) then c---> time averaged fields do k=1,l do j=1-ih,mp+ih do i=1-ih,np+ih utav(i,j,k)=utav(i,j,k) + u(i,j,k,0)/nplot vtav(i,j,k)=vtav(i,j,k) + v(i,j,k,0)/nplot wtav(i,j,k)=wtav(i,j,k) + w(i,j,k,0)/nplot thtav(i,j,k)=thtav(i,j,k) + th(i,j,k)/nplot ptav(i,j,k)=ptav(i,j,k) + p(i,j,k)/nplot if(mhd.eq.1) then bxtav(i,j,k)=bxtav(i,j,k) + bx(i,j,k,0)/nplot bytav(i,j,k)=bytav(i,j,k) + by(i,j,k,0)/nplot bztav(i,j,k)=bztav(i,j,k) + bz(i,j,k,0)/nplot endif enddo enddo enddo endif c if(iwrite.eq.1.and.(it-itstart)/nplot*nplot.eq.(it-itstart)) then c if (itav.eq.1) then c call iowrsh(utav,vtav,wtav,thtav,ptav,bxtav,bytav,bztav) c---> time averaged fields, special (reinitilisation) c do k=1,l c do j=1-ih,mp+ih c do i=1-ih,np+ih c utav(i,j,k)=0. c vtav(i,j,k)=0. c wtav(i,j,k)=0. c thtav(i,j,k)=0. c ptav(i,j,k)=0. c if(mhd.eq.1) then c bxtav(i,j,k)=0. c bytav(i,j,k)=0. c bztav(i,j,k)=0. c endif c enddo c enddo c enddo c else c call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . w(1-ih,1-ih,1,0),th,p, c . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) c . w(1-ih,1-ih,1,0),chm) c endif !itav c endif if((it-itstart)/noutp*noutp.eq.(it-itstart)) then if (mype.eq.0) print 210,it,dt,time, u(15,15,1,0) if (mype.eq.0) print 211,cr1,cr2,crb 210 format(/,10x,' it=',i9,' dt(sec)=',f7.2, & ' time(solar days)=',f7.2,/,' u=', e23.16) c 210 format(/,8x,' it=',i5,' dt(sec)=',f7.2,' time(min)=',f7.2) 211 format(1x,'cour,lipsh,courB:',3e11.4,5x,e11.3) do 250 k=1,l do 250 j=1,mp do 250 i=1,np 250 pfx(i,j,k)=rho(i,j,k) #if (SEMILAG == 1) if(lagr.eq.1) call interp(pfx,x0,y0,z0,1) #endif if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) !if (V5D == 1) ! inbr=inbr+1 ! =6 ! if (mype.eq.0) print * ! if (mype.eq.0) print *,'RHSDIV START' ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) !endif call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) !if (V5D == 1) ! inbr=inbr+1 !=7 ! if (mype.eq.0) print *,'RHSDIV DONE' ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) !endif if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,2)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) oy(i,j,k,2)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) oz(i,j,k,2)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) enddo enddo enddo call rhsdiv(ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2), . oz(1-ih,1-ih,1,2),rh0,pfz,1) endif c call diagnos( u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), c * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), c * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, c * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,dragx(it),dragy(it),zs,zh, c * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) #if ( ENERGY > 0) if( ianlfl.eq.1 ) then call energy(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0), oz(1-ih,1-ih,1,0), . th,p,ehise,ivis,kf) endif if( kf.eq.nfstop) then do k=1,nfstop write(21,111) k,(ehise(k,i),i=1,17) enddo endif 111 format(2x,i5,17(e15.7,1x)) #endif #if (GKS == 1) #if (PLOTPL == 1) call plot(th, u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), * bz(1-ih,1-ih,1,0), * p,pfy,chm,qv,qc,qr,qia,qib,lipps,tke,pfz,tau(1,1-ih,1-ih,1)) if(ivis.eq.1) then call plothise(hise,it+1,nthv) call plotdrag(fmx,fmy,it) end if #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),pfx,pfy,pfz,1) call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif #endif #if (V5D == 1) inbr=inbr+1 call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) #endif end if ccccccccccccccccccccccccccccccccccc check for stability of computations ccccccccccccccccccccccccccccccccccc if(lagr.eq.1.and.cr2.gt.3.) then if (mype.eq.0) print 211,cr1,cr2,tt/timescale call end_code(iwr) stop 'lipshitz' endif if(lagr.eq.0.and.cr1.gt.3.) then c if(lagr.eq.0.and.cr1.gt.300.) then do 299 k=1,l do 299 j=1,mp do 299 i=1,np 299 pfx(i,j,k)=rho(i,j,k) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) call diagnos( u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,dragx(it),dragy(it),zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) if (mype.eq.0) print 211,cr1,cr2,tt/timescale call end_code(iwr) stop 'courant' endif ccccccccccccccccccccccccccccccccccc close stability checks ccccccccccccccccccccccccccccccccccc 1000 continue 10 continue close time integration call ttend(1) call ttprt(mype,0) #endif /* ANALIZE == 0 */ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c analize old data from tape ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (ANALIZE > 0) tt=0.0 ! time (sec.) of first record in file it=0 ! timestep of first record in file ianlfl=nanlfl nfstop=ianlfl*nfil+(1-ianlfl)*nfilo icomm=1 ! don't touch c------------------------------------------------------------------ namex=4H e05 ! specials for labeling tapes chrate=2. ! visc=50.00e-3 ! c------------------------------------------------------------------ do 1000 kf=1,nfstop ! read stored files from 1st to nfstop if(ianlfl.eq.1) then tt=tt+dtfil(kf)*ntfil(kf) it=it+ntfil(kf) time=tt/timescale call ioread(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,icomm) else tt=tt+dtfilo(kf)*ntfilo(kf) it=it+ntfilo(kf) time=tt/timescale call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), . icomm) c . w(1-ih,1-ih,1,0),chm,icomm) endif print 309, kf,time,tt 309 format(4x,' read tape; kf, time, tt:',i5,f7.2,e11.4) print 310,it,dt,time 310 format(8x,' it=',i5,' dt(sec)=',f7.2,' time(days)=',f7.2, & 'u=',e23.16) c------------------- if(kf.ge.nfstart) then ! begin analysis if(((kf-nfstart)/nplo*nplo.eq.(kf-nfstart)).or. . (kf.eq.nfstart)) then call topolog(x,y) call metryc(x,y,z) call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif if(ianlfl.eq.1) then if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(irid.eq.1) . call rical(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,qv,qc,0) if(mhd.eq.1) . call rhsdiv(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), . bz(1-ih,1-ih,1,0),rh0,pfz,1) if(idia.eq.1) then call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) endif endif c call sumcns(chm(1-ih,1-ih,1,ichm1),pfy,rho,chemh(kf,ichm1),1) c call sumcns(chm(1-ih,1-ih,1,ichm2),pfy,rho,chemh(kf,ichm2),1) c call sumcns(chm(1-ih,1-ih,1,ichm3),pfy,rho,chemh(kf,ichm3),1) #if (GKS == 1) #if (PLOTPL == 1) call plot(th,u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), * bz(1-ih,1-ih,1,0),p,pfy,chm,qv,qc,qr,qia,qib,lipps, * tke,pfz,tau(1,1-ih,1-ih,1)) #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),pfx,pfy,pfz,1) if(kf.ne.1 .or. time.gt.0.) then call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0),th, * pfx,pfy,pfz) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C itpwr=0 C if(itpwr.eq.1) then C iun=39+kf C write(iun) namex,chrate,visc,time C do k=1,l C do j=1,mp C do i=1,np C write(iun) u(i,j,k,0), v(i,j,k,0), w(i,j,k,0), C * chm(i,j,k,1),chm(i,j,k,2),chm(i,j,k,3), C * pfx(i,j,k) ,pfy(i,j,k) ,pfz(i,j,k) C enddo C enddo C enddo C endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #endif #endif #if (V5D == 1) call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,kf) #endif end if endif ! end analysis c------------------- 1000 continue ! end reading of records c------------------------------------------------------------------ if(ichm.eq.1) then do ispc=1,nspc print 789, (chemh(kf,ispc), kf=1,nfstop) enddo 789 format(4x,5e11.4) endif #endif /* ANALIZE == 1 */ call end_code(iwr) stop 'main' end c.....7..0.........0.........0.........0.........0.........0.........012 block data blanelas c set grid sizes with parameter statements include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,nmp=np*mp) parameter (nmsgs=n*m,nmmsgs=nms*mms) parameter(nmsgsp=(np+2*ih)*(mp+2*ih), . nmmsgsp=(nmsp+2*ih)*(mmsp+2*ih)) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create basic setups c c-----------------------------------------------------------------c c---> dx,dy,dz - domain grid increments/dimensions c c If isphere=1 only need to specify dz c c If lxyz=1 do not specify ANY of dx,dy,dz c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c---> igrid=0 for A grid (default); c c---> igrid=1 for B grid (special option) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc data igrid/0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c I/O OPTIONS for different types of binary formats c c-----------------------------------------------------------------c c---> ioptr=0 read data from HP/Convex format c C on Cray set correct assign options c c---> ioptr=1 read data from Cray MPP (T3D,T3E) format c c---> ioptr=2 read data from Cray PVP (C90,J90,Y-MP) format c c c c---> ioptw=0 write data to HP/Convex format c C on Cray set correct assign options c c---> ioptw=1 write data to Cray MPP (T3D,T3E) format c c---> ioptw=2 write data to Cray PVP (C90,J90,Y-MP) format c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/hpcray/ ifcw,ifcr,ioptw,ioptr data ioptw,ioptr/0,0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc CREATE/READ HISTORY (fort.9) AND ANLYSIS (fort.11) TAPE OF THE JOB c-----------------------------------------------------------------c c---> nrestr: restart file from the history tape (fort.10) c---> dtfil: dt in every file; c---> ntfil: number of dt in every file c---> nrestro: read file from the analysis tape (fort.12) c---> dtfilo: dt in every file; c---> ntfilo: number of dt in every file ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/histape/ dtfil(nfil ),dtfilo(nfilo), . ntfil(nfil ),ntfilo(nfilo), . nrestr,nresto data dtfil /nfil *dt_fil /,ntfil /nt_fil0 ,nfilm *nt_film0 / data dtfilo/nfilo*dt_filo/,ntfilo/nt_filo0,nfilom*nt_filom0/ data nrestr/nfil/,nresto/nfilo/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create initialization of environmental state, c see comments in subroutine tinit_i or tinit_r c-----------------------------------------------------------------c c--> initi=1 idealized initialization (tinit_i) c--> initi=0 realistic initialization from sounding (tinit_r) c--> lipps=0 Boussinesq c--> lipps=1 Anelastic, isentropic c--> lipps=2 Anelastic, Clark-Farley c--> lipps=3 Anelastic, isothermal ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/tinits/ initi,lipps data initi/1/ data lipps/1/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create model boundaries c c-----------------------------------------------------------------c c---> iab,iabth,iabqw - absorber flags for velocity, theta, water c c---> ipolar - EXPLICIT polar absorber flag c c ( can be nonzero ONLY if isphere = 1) c c---> dxabL- thickensses of left lateral absorbers in x [m] c c---> dxabR- thickensses of right lateral absorbers in x [m] c c---> dyab - thickensses of lateral absorbers in y [m] c c---> dyabp- thickensses of EXPL. lateral absorbers in y [m] c c---> zab - base of sponge in vertical (z) [m] c c---> towxL- absorber time scale in x (left side) [s] c c---> towxR- absorber time scale in x (right side) [s] c c---> towy - absorber time scale in y [s] c c---> towyp- explicit absorber time scale in y [s] c c---> towz - absorber time scale in z [s] c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar data relx/nmp*0./,rely/nmp*0./ ! initializes arrays c data iab,iabth,iabqw/0,0,0/ c data iab,iabb,iabth,iabqw/1,1,0,0/ data iab,iabb,iabth,iabqw/0,0,0,0/ data dxabL,towxL/2800.,1.e10/ data dxabR,towxR/2800.,1.e10/ c ---- IMPLICIT lateral sponge parameters: regular - affect ALL vel. fields c data dyab ,towy /2800.e3,86400./ data dyab ,towy /2800.,86400./ c ---- special EXPLICIT POLAR sponge parameters (set up any of u,v,w,th in main) c ---- (see MAIN code to choose which fields to damp -- search on "ipolar") c ---- (see routine absorber for type of absorber, eg, "linear", ...) c --- RECOMMENDED HS SETTINGS: towyp such that ONLY 1 POINT is in absorber c Strongly Damp ONLY u & v (towyp/dt < 100) c iabth = 0 (eg, do NOT damp theta field) data ipolar/0/ ! flag for use of scalar sponge c data dyabp,towyp/0.278e6, 1000./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 2400./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 4500./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 8600./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6,13300./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.500e6, 8600./ ! 4.5 degrees of latitude: Earth c data dyabp,towyp/0.834e6, 8600./ ! 7.5 degrees of latitude: Earth c data dyabp,towyp/1.668e6,13300./ ! 15 degrees of latitude: Earth c data dyabp,towyp/2.222e8,8600./ ! 30 degrees of latitude: Sun c data dyabp,towyp/2.222e8,864000./ ! 15 degrees of latitude: Sun data dyabp,towyp/1.042e8,86400./ c ---- vertical sponge parameters cc data zab ,towz / 2.365e8,0.2592E+06/ !zab=(l-3)*dz00 cc data zab ,towz /-2.4053125e8,0.2592E+06/ !zab=(l-6)*dz00 data zab ,towz /0.e3,1.555e8/ !60 solar days 864000. c data zab ,towz /12.e3,864000./ c data zab ,towz / 2.365e8,0.2592E+06/ !zab=(l-3)*dz00 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for pressure boundary treatment ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/indx/ e1,e2,e3 c data e1,e2,e3/1.,0.,0./ ! 0_th order cc data e1,e2,e3/1.5,-0.5,0./ ! 1_th order data e1,e2,e3/1.875,-1.250,0.375/ ! 2_nd order; default ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for inflow/outflow velocity dignostics c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/vbcdg/ vbcdiag(9) data vbcdiag/9*0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for grag coefficients ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag data dragx/nth*0./,dragy/nth*0./ data idrag/0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc constants for pressure solver; c c-----------------------------------------------------------------c c---> itp_,epp_ are max number of iterations and constraint of c c---> accuracy max|1/rho*div(rho*v)*dt| and run, correspondingly for itp0,epp0 and itp1,epp1; c c---> see string "epp1=" for other opt. c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/itero0/ epp0,epp1,itp0,itp1 data itp0,epp0,itp1,epp1/600,1.e-6,300,1.e-5/ c --- niter,nitav are number/average number of pressure c iterations at/up to a given timestep c --- miter,mitav are number/average number of pressure c iterations at/up to a given timestep in the outer c mtri loop if mtrord=2. common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem data niter,nitsm,icount,miter,mitsm,jcount,eer,eem/6*0,2*0./ common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb data niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb/6*0,2*0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create basic constants (tt00,th00,pr00,rh00 must be consistent): c c-----------------------------------------------------------------c c---> g - gravity (m/s^2) c c---> rg - dry gas constant (J/kgK) c c---> tt00 - ground level temperature (K) c c---> th00 - ground level potential temperature (K) c c---> pr00 - ground level pressure (Pa) c c---> rh00 - ground level density (kg/m^3) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z data g,rg,tt00,th00,pr00,rh00 ! 1 /182.03,13732.,1.79e6,1.79e6,8.90e11,36.2/ !Rafaella Yoda 1 /717.3286,13732.,3621558.24986,2.3222e6,2.01379e13,404.9355/ !sun - ambient values cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create environmental profiles (use subroutine tinit_i) c c-----------------------------------------------------------------c c---> u00 - wind constant; x component, profile U (m/s) c c---> v00 - wind constant; y component, profile V (m/s) c c---> st - stability parameter; inverse scale height (m^-1) c c---> u0z - vertical wind shear dU/dz (s^-1) c c---> v0z - vertical wind shear dV/dz (s^-1) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc data u00, v00, st, u0z, v0z c $ /20., 0., 1.02e-5, 0.e-3, 0.e-3/ $ /0.0, 0.0, 0.000, 0.e-3, 0.e-3/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create time-dependent lower boundary; specifics in topolog routine ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) data zs,zh,gi,s13,s23,h13,h23/nmsgsp*0.,nmsgsp*0.,nmsgsp*0., . nmsgsp*0.,nmsgsp*0.,nmsgsp*0.,nmsgsp*0./ common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) data zsd,zhd,strxd,stryd/nmsgsp*0.,nmsgsp*0.,nmsgsp*0.,nmsgsp*0./ data strxx,strxy,stryx,stryy . /nmsgsp*1.,nmsgsp*0.,nmsgsp*0.,nmsgsp*1./ data xcr,ycr/nmsgsp*0.,nmsgsp*0./ data xr1,xr2,xc1,xc2/mp*0.,mp*0.,mp*0.,mp*0./ data tt,tend/0.,-1.e10/ data time/0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc coriolis force specification c c-----------------------------------------------------------------c c---> fcr0 - coriolis parameter (s^-1) c c---> ang - f=fcr0*sin(ang) for f- or beta-plane approximation c c---> btpl - beta-plane approximation on or off c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs c data fcr0,ang,initprs/0.,0.,0/ ! tank c data fcr0,ang,initprs/20.76e-6,30.,0/ ! BPTau - 7 days c data fcr0,ang,initprs/1.4532e-5,30.,0/ ! BPTau - 10 days c data fcr0,ang,initprs/10.3888e-6,30.,0/ ! BPTau - 14 days c data fcr0,ang,initprs/6.6111e-6,0.,0/ ! Sun - 22 days data fcr0,ang,initprs/6.060171e-6,0.,0/ ! Sun - 24 days c data fcr0,ang,initprs/4.55104e-6,0.,0/ ! BPTau - 28 days c data fcr0,ang,initprs/5.0153e-6,0.,0/ ! sun - 29 days data btpl/0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c---> rd - sphere radius bottom domain (m) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) data rds/ 4.17594e8/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create algorithm for sperical metric forces c c-----------------------------------------------------------------c c---> mtrord - order of approximation (1 or 2), mtrord=3 beta plane c---> mtrimx - No of iterations (ge.2) for mtrord=2 c c---> mtrord=mtrord*isphere+1-isphere c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/metrif/ mtrord,mtrimx data mtrord,mtrimx/2,2/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create variables for SGS model c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes data hfx/nmsgsp*0./,qfx/nmmsgsp*0./ c-----------------------------------------------------------------c c turbulent scaling parameters as given by Schumann in c c Theor. Comp. Fluid Dyn (1991) 2:279-290; note that Prndt=cm/ch c c-----------------------------------------------------------------c common/sgscnst/ ceps,cL,cm,css,prndt c salt in water c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/685.3973/ !Gill c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/1.00/ !Gill c salty water + heat c (salt diffusivity neglected, added viscosity taken into account) c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/7.458/ !Schumann c atmospheric air c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/.42/ !Schumann c data ceps/.930/,cL/1.e15/,cm/.1000/,css/.180/,prndt/.33/ !Moeng-Nieuwstadt c solar convection c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/0.5/ !SUN c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/0.1/ !SUN data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/1.0/ !SUN c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/100.0/ !SUN c-----------------------------------------------------------------c common/stresd/ diagstr(8),ivis,irid,itstr common/strese/ diagste(12) data diagstr/8*0./,diagste/12*0./ data ivis,itkes/ivs0,itke/ common/slip/ noslip !mod bbc common/slipb/ noslipb data noslip/0/ data noslipb/1/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c surface layer fluxes for heat/moisture/momentum c c-----------------------------------------------------------------c c---> hf00 - sensible heat flux [K m/s] c c---> qf00 - latent heat flux [kg/kg m/s] c c---> cdrg - drag coefficient c c---> inorm- normalization switch c c---> zi - height of lowest inversion (min Richardson number) c c---> wstr - scaling vertical velocity in mixin-layer theory c c---> tstr - sclaing temperature in mixin-layer theory c c---> qstr - scaling water-vapor mixing ratio in mixin-layer theory ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm data inorm/0/,zi,wstr,tstr,qstr/4*1./ c Sun - hf00=sls/(cp*4*pi*rds**2) data hf00/4.959e3/,qf00/0.e-3/,cdrg/0.000/ !Sun rds=424.75Mm c data hf00/3.579e3/,qf00/0.e-3/,cdrg/0.000/ !Sun rds=500Mm c data hf00/1.7895e3/,qf00/0.e-3/,cdrg/0.000/ c data hf00/0.89475e3/,qf00/0.e-3/,cdrg/0.000/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create HF filter from the upwind option in transport schemes c c-----------------------------------------------------------------c c---> liner - flag for activating mpfl'th smoothing c---> mpfl - decrease to first order every mpfl'th timestep c---> ampd - advection order operator for mpflth smoothing ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) data mpfl,kampd/nth,3*0/ !default c data mpfl,kampd/1,3*0/ !default ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct moist model c-----------------------------------------------------------------c create condensation/evaporation constants common/cmoist/ rv,t00,ee0,hlat data rv,t00,ee0,hlat/461.,273.16,611.,2.53e6/ create rain constants (ice=0 case) common/rain/ rac,qctr,rc data rac,qctr,rc/1.e-3, .005e-3, 2.2/ c data rac,qctr,rc/1.e-3, .5e-1, 2.2/ common/dftemp/dftmx,dftmn,dftav,dftsd data dftmx,dftmn,dftav,dftsd/4*0./ c time step of microphysical model (no more than 30s for explicit) common/tmoist/ dtm data dtm/30./ ! Wojtek recommends dtm < 300 s cc initialization for ice=1 case common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/rain_p1/ dconc,ddisp common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn common/latent/ hlatv,hlats create parametrs for general precip formulation: cc mass, terminal velocity, diameter data ar,br,cr,dr /5.2e2,3.,130.,0.5/ data as,bs,cs,ds /2.5e-2,2.,4.,0.25/ cc collection ef., alpha, beta data er,alphr,betr /0.8, 1., 2./ data es,alphs,bets /0.2, .3, 3./ cc No data anor,anos /2*1.e7/ cc latent heats: data hlatv,hlats /2.53e6,2.84e6/ cc cloud droplet concentration (per cc) data dconc /200./ ! must be between 50 and 2000 cc limiting temperatures data tup,tdn /273.,263./ cc gammas: data gamb1r,gambd1r /6.0,11.7/ data gamb1s,gambd1s /2.0,2.56/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create mountain c-----------------------------------------------------------------c c amp - maximum height of mountain [m] c xml - zonal scale of mountain [m] or [radians] c xml0 - zonal shift from the domain center [m] or [radians] c yml - meridional scale of mountain [m] or [radians] c yml0 - meridional shift from the domain center [m] or [radians] c angle- angle to skew the mountain ridge [radians] ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/gora/ xml,yml,amp,xml0,yml0,angle data amp,xml,yml,xml0,yml0,angle/0.,0.e0,0.,3*0./ c data amp,xml,yml,xml0,yml0,angle/2.e3,2*.34906585,3*0./ end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES INIT / FINALIZE / CHECK SETUP CONSISTENCY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine check_error(lipps) include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z c---------------------------------------------------------- c --- check basic computational setup if (nth.lt.nt) then write(*,7) 7 format('+++error: nth < nt. nth =',i8,' nt=',i8) stop end if #if (SEMILAG == 0) if(lagr.eq.1) then print *,'+++error: lagr=1 but SEMILAG=0' stop endif #else if(lagr.eq.0) then print *,'+++error: lagr=0 but SEMILAG=1' stop endif #endif #if (J3DIM == 0) if(m.ne.1) then print *,'+++error: m=/=1 but J3DIM=0' stop endif #else if(m.eq.1) then print *,'+++error: m=1 but J3DIM=1' stop endif #endif if (icyz.eq.1) then c if (lipps.ne.-1) then c print *,'+++error: with icyz=1 lipps must be -1' if (lipps.ne.0) then print *,'+++error: with icyz=1 lipps must be 0' stop endif if (st.ne.0.) then print *,'+++error: with icyz=1 st must be 0.' stop endif endif check absorber thickness c if(dxab.gt.((n-1)*dx).or.(dyab*j3).gt.((m-1)*dy)) c . stop 'absorber thicker than doMAin' c---------------------------------------------------------- c --- check basic physical setup c---------------------------------------------------------- check moisture parameters #if (MOISTMOD == 0) if(moist.eq.1) then print *,'+++error: moist=1 but MOISTMOD=0' stop endif #endif #if (MOISTMOD > 0) if(moist.eq.0) then print *,'+++error: moist=0 but MOISTMOD=/=0' stop endif #if (MOISTMOD == 1) if(iceab.eq.1) then print *,'+++warning: iceab=1 but MOISTMOD=1' print *,'+++set iceab=0 for degrading qia,qib,fqia,fqib' print *,'+++or comment following "stop" command' stop endif #endif #endif check equation of state at surface perr=(1.-rh00*rg*tt00/pr00)*100. if(abs(perr).gt.5.) then print*,'+++warning: eq. of state is', . ' in error by',perr,'% at surface' c special c stop else print*,' eq. of state is in error by',perr,'% at surface' end if check domain depth if(lipps.eq.0) then zmax=pr00/(rh00*g) if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' c stop end if end if if(lipps.eq.1) then capi=1./cap sdi=1./7000. ! density scale height (m^-1) zmax=capi/sdi if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' stop end if end if if(lipps.eq.2) then cs=g/(cp*tt00*st) zmax=-alog(1.-1./cs)/st if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' c special c stop end if end if return end subroutine init_code(ioptwr) include 'param.nml' include 'msg.inc' common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (PARALLEL == 1) #if (SGI_O2K > 0) call start_pes(0) #endif #endif #if (PARALLEL == 2) call MPI_Init(ierr) COLD if (mype.eq.0) call time_comp(0) #endif c set geometry information for each processor, i.e., c where it is, who its neighbors are, etc. call geomset() c test updates configuration, go to 'test' for details c call test c call testreal #if (GKS == 1) call opngks call gsclip(0) call ncargdef #endif if (mype.eq.0) then print *,'*** STARTING TIME ***' call timefun() end if call ttini() #if (HP > 0 || SGI_O2K > 1 ) if (mype.eq.0) then if(ioptwr.gt.0) then #if (HP > 0) ifcr = CRAYOPEN ("./ftn09", 0, o'644') #endif #if (SGI_O2K > 1) ifcw = CRAYOPEN ("./fort.9", 1, o'644') #endif endif if(ioptr.gt.0) then #if (HP > 0) ifcr = CRAYOPEN ("./ftn10", 0, o'644') #endif #if (SGI_O2K > 1) ifcr = CRAYOPEN ("./fort.10", 0, o'644') #endif endif endif #endif return end subroutine end_code(ioptwr) include 'param.nml' include 'msg.inc' common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (GKS == 1) call clsgks #endif #if (HP > 0 || SGI_O2K > 1 ) if(ioptwr.gt.0) then if (mype.eq.0) then ierr = CRAYCLOSE (ifcw) endif endif #endif if (mype.eq.0) then print *,'*** ENDING TIME ***' call timefun() end if #if (PARALLEL == 2) COLD if (mype.eq.0) call time_comp(-1) call MPI_Finalize(ierr) #endif return end #if (PARALLEL == 2) subroutine time_comp(it) include 'param.nml' include 'msg.inc' real*8 timeval,timestart,timeit,timestart0 common/timecp/ timeval,timestart,timeit,timestart0 if (mype.eq.0) then timeit = MPI_Wtime() CTEST print *,'time_comp:',it,timeit if (it.eq.0) then timestart = timeit timestart0= timestart else if (it.lt.0) then timeval = timeit - timestart0 write(*,*)'wallclock time - total =',timeval,'sec' print *,timeval,timestart,timeit,timestart0 else timeval = timeit - timestart timestart = timeit write(*,*)'wallclock time in timecount:',it,' =',timeval,'sec' endif endif endif return end #endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES TOPOGRAPHY / MESH GEOMETRY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccc subroutine topolog(x,y) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension x(n),y(m) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) dimension xr3(mp),xr4(mp),xc3(mp),xc4(mp), + yr3(np),yr4(np),yc3(np),yc4(np) #if (PARALLEL == 0) equivalence (xr1,xr3),(xr2,xr4),(xc1,xc3),(xc2,xc4), + (yr1,yr3),(yr2,yr4),(yc1,yc3),(yc2,yc4) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/mihaistr/ acns,beta,dzb,hpsl,kst common/gora/ xml,yml,amp,xml0,yml0,angle parameter(syfact=2., iyorder=5, + sycoef1=1./syfact,sycoef2=(syfact-1.)/syfact) parameter(sxfact=2., ixorder=5, + sxcoef1=1./sxfact,sxcoef2=(sxfact-1.)/sxfact) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c--> itopo=1 - read topo array from tape and redistribute it to pe's c--> ntop,mtop - dimension of topo array from tape c--> if (ntop.ne.n) or (mtop.ne.m) then we need interpolation ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(itopo=0,ntop=n,mtop=m) dimension zstmp(np,mp), ! tmp array for transfer between pe's . zsfull(n,m), ! topo array on full domain (size n x m) . zstape(ntop,mtop) ! topo araay on tape (size ntop x mtop) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c MOUNTAIN SHAPE FUNCTIONS cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct fortran statement functions for the boundary shape create time dependence of the lower boundary; if time dependent lower boundary condition is used for initialisation make sure tend is multiple of dt construct fortran statement functions for the boundary shape c++++++++++++++++++++++++++ C Williamson et al. test case c rd(xln,ylt)=sqrt((xln/xml)**2+(ylt/yml)**2) c profm(rad)=amax1(0.,1.-rad) c profm(rad)= exp(-rad**2) c profm(rad)=.5*(1.+cos(pi*rad)) c++++++++++++++++++++++++++ c special for the conical mountain on the pole ccccc c rd(xln,ylt)=abs(ylt-y0) c profm(rad)=amax1(0., 1.-gamm*rad/rnot) c rnot = 2*acos(-1.)/128. * 10. c gamm=1. c++++++++++++++++++++++++++ c rd(xx,yy)=sqrt((xx/xml)**2+j3*(yy/yml)**2) c fi(rad)=amp*exp(-rad**2) c fi(rad)=.5*(1.+cos(pi*rad)) c fi(rad)=amp/(1.+rad**2) ! klemp mountain c fi(rad)=amp*exp(-(rad/xml)**2)*(cos(pi*rad*.25e-3))**2 c membranas c fi(rad)=-.5*(1.+cos(pi*rad)) c fid(rad)=.5*pi*sin(pi*rad) ! hyd. jump c fi(rad)=amp/(sqrt(1.+rad**2))**3 ! cylindrical annulus c fi(rad,is,r1,r2)=(rad**2/r1**2)* c . (1.-( ( ((r2/r1)**(is+2))-1.)*((rad/r1)**(is-2)) c . +( ((r2/r1)**(is-2))-1.)*((r2/rad)**(is+2)) ) c . /(((r2/r1)**(2*is))-1.) ) c fid(rad)=0. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct statement functions for the horizontal coordinate mapping cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c domains are: -1 < yln < 1 and -1 < xln < 1 c and ranges are: -1 < yphy < 1 and -1 < xphy < 1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c IDENTITY TRANSFORMATION (DEFAULT) c xphy(xln,yln,tln)=xln ! X0 c yphy(xln,yln,tln)=yln ! Y0 c++++++++++++++++++++++++++ c --- Y GRID STRETCHING c syfact - stretching factor at y00 c iyorder - order of polynomial function (odd order >= 3 required) c sycoef1 - inverse stretching factor at equator c sycoef2 - nonlinear coefficient c yphy(xln,yln,tln)=sycoef1*yln+sycoef2*yln**iyorder ! Y_[-1,1] C yphy(xln,yln,tln)=yln*(sycoef1 + (1.-sycoef1)*yln*yln* ! Y_cyc C + (10.-15.*yln+6.*yln*yln) ) ! Y_[0,1] c++++++++++++++++++++++++++ c --- X GRID STRETCHING c sxfact - stretching factor at x00 c ixorder - order of polynomial function (odd order >= 3 required) c sxcoef1 - inverse stretching factor at equator c sxcoef2 - nonlinear coefficient c xphy(xln,yln,tln)=sxcoef1*xln+sxcoef2*xln**ixorder ! X_[-1,1] cc xphy(xln,yln,tln)=xln*(sxcoef1 + (1.-sxcoef1)*xln*xln* ! X_cyc cc + (10.-15.*xln+6.*xln*xln) ) ! X_[0,1] cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (TIMEPLT == 1) call ttbeg(6) #endif c definitions for mihai vertical stretching beta = 1. if (istab.eq.1) then select case(l) case(24) kst = 8 !top of stable layer below SCZ case(47) kst = 15 !top of stable layer below SCZ case(64) kst = 19 !top of stable layer below SCZ case(93) kst = 29 !top of stable layer below SCZ case(185) kst = 57 !top of stable layer below SCZ end select endif c beta = 2.0 if (istab.eq.1) then hpsl=dz*(kst-1.) else hpsl=-1. endif acns = alog((1.+(exp(beta)-1.)*dzb)/ & (1.+(exp(-beta)-1.)*dzb))/(2.*beta) !mihai c----------------- end of mihai vertical stretching defintions pi=acos(-1.) pi2=2.*pi pih=pi/2. piho=1./pih pi2o=1./pi2 xnorm=x(n)-x(1) ynorm=y(m)-y(1) xnormi=1./xnorm ynormi=float(j3)/(float(1-j3)+j3*ynorm) xml=pi/9. yml=xml c--- compute horizontal grid point "physical" locations do j=1,mp do i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j c xcr(i,j)=xnorm*xphy(x(ia)*xnormi,y(ja)*ynormi,tt) c ycr(i,j)=ynorm*yphy(x(ia)*xnormi,y(ja)*ynormi,tt) xcr(i,j)=x(ia)*(rds*isphere+(1-isphere)) ycr(i,j)=y(ja)*(rds*(isphere+icylind)+(1-(isphere+icylind))) enddo enddo c do j=1,mp c ja=(mpos-1)*mp + j c if(npos.eq.1) print *,'ycr:',ja,ycr(1,j)/rds c enddo c do i=1,np c ia=(npos-1)*np + i c if(mpos.eq.1) print *,'xcr:',ia,xcr(i,1)/rds c enddo c------------------------------------------------------------------ compute topografy angep=ang-1.e-10 cang=cos(pi*angle/180.) sang=sin(pi*angle/180.) yj0=pi/180.*ang x0 = 1.5*pi*isphere+(1-isphere)*0.5*(x(1)+x(n)) y0 = pi/6. *isphere do 20 j=1,mp do 20 i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j c --- compute trig and coriolis functions yj=ycr(i,j)*rdsi icoord=isphere+icylind cosa(i,j)=cos(yj)*icoord+(1-icoord)*1. sina(i,j)=sin(yj)*icoord+(1-icoord)*0. tnga(i,j)=tan(yj)*icoord+(1-icoord)*0. fcr2(i,j)=icoord*fcr0*cosa(i,j) * +(1-icoord)*fcr0*(cos(yj0)-btpl*sin(yj0)*yj) fcr3(i,j)=icoord*fcr0*sina(i,j) * +(1-icoord)*fcr0*(sin(yj0)+btpl*cos(yj0)*yj) c --- compute lower boundary deflection c xx= cang*(x(ia)-x0)+sang*(y(ja)-y0) c yy=-sang*(x(ia)-x0)+cang*(y(ja)-y0) c rr=rd(xx,yy) zs(i,j)= 0. zsd(i,j)= 0. zh(i,j) = zb zhd(i,j)= 0. c zs(i,j)=amp*profm(rr) c zs(i,j)=amp*cvmgmxx(0.,profm(rr),1-rr) zs(i,j)=0. if( tt.eq. 0. ) then zh(i,j)=zb zhd(i,j)=0. endif 20 continue C nois=0 C if(nois.eq.1) then C ampns=0.5e-3*nois C call nois2(zs,zsd,1) C call nois2(zh,zhd,2) C do j=1,mp C do i=1,np C zsd(i,j)= 0. C zs(i,j)=ampns*zs(i,j) C zhd(i,j)= 0. C zh(i,j)=ampns*zh(i,j)+(l-1)*dz C enddo C enddo C endif if (itopo.eq.1) then !read topografy from tape if (mype.eq.0) then call readtopo0(zs,zstmp,zstape,zsfull,ntop,mtop) else call readtopok(zs,zstmp) end if endif call update( xcr,np,mp,1,np,mp,iup) call update( ycr,np,mp,1,np,mp,iup) call update(cosa,np,mp,1,np,mp,iup) flush(6) #if (POLES == 1) c-------------------------------------------c create values for metric terms at the boundary c-------------------------------------------c #if (PARALLEL > 0) do j=1,mp xr3(j)=0. xc3(j)=0. xr4(j)=0. xc4(j)=0. enddo do i=1,np yr3(i)=0. yc3(i)=0. yr4(i)=0. yc4(i)=0. enddo #endif if (leftedge.eq.1) then do j=1,mp xr3(j)=xcr(1,j) xc3(j)=ycr(1,j) enddo endif if (rightedge.eq.1) then do j=1,mp xr4(j)=xcr(np,j) xc4(j)=ycr(np,j) enddo endif if (botedge.eq.1) then do i=1,np yr3(i)=xcr(i,1) yc3(i)=ycr(i,1) enddo endif if (topedge.eq.1) then do i=1,np yr4(i)=xcr(i,mp) yc4(i)=ycr(i,mp) enddo endif #if (PARALLEL > 0) CALL MPI_ALLReduce(xr3,xr1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xr4,xr2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc3,xc1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc4,xc2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(yr3,yr1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yr4,yr2,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc3,yc1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc4,yc2,np,DC_TYPE,MPI_SUM,my_col,ier) #endif if (leftedge.eq.1) then do j=1,mp xcr(0,j)=xr2(j)-pi2*rds ycr(0,j)=xc2(j) enddo endif if (rightedge.eq.1) then do j=1,mp xcr(np+1,j)=xr1(j)+pi2*rds ycr(np+1,j)=xc1(j) enddo endif if (botedge.eq.1) then do i=1,np ia=(npos-1)*np + i ib=ip(ia) ic=ib-n/2 xcr(i,0)= xcr(i,1) ycr(i,0)= ycr(i,1) ! yc1(ic) ! if(mype.eq.2) print*,'STRA:',i,xcr(i,0),xcr(i,1),xcr(i,2), ! . ycr(i,0),ycr(i,1),ycr(i,2) enddo endif if (topedge.eq.1) then do i=1,np ia=(npos-1)*np + i ib=ip(ia) ic=ib-n/2 xcr(i,mp+1)= xcr(i,mp) ycr(i,mp+1)= ycr(i,mp) ! yc2(ic) enddo endif #endif c-------------------------------------------c create boudary values for absorber definition c-------------------------------------------c #if (PARALLEL > 0) do j=1,mp xr3(j)=0. xc3(j)=0. xr4(j)=0. xc4(j)=0. enddo do i=1,np yr3(i)=0. yc3(i)=0. yr4(i)=0. yc4(i)=0. enddo #endif if (leftedge.eq.1) then do j=1,mp xr3(j)= xcr(1,j) xc3(j)=cosa(1,j) enddo endif if (rightedge.eq.1) then do j=1,mp xr4(j)= xcr(np,j) xc4(j)=cosa(np,j) enddo endif if (botedge.eq.1) then do i=1,np yr3(i)= ycr(i,1) yc3(i)=cosa(i,1) enddo endif if (topedge.eq.1) then do i=1,np yr4(i)= ycr(i,mp) yc4(i)=cosa(i,mp) enddo endif #if (PARALLEL > 0) CALL MPI_ALLReduce(xr3,xr1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xr4,xr2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc3,xc1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc4,xc2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(yr3,yr1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yr4,yr2,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc3,yc1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc4,yc2,np,DC_TYPE,MPI_SUM,my_col,ier) #endif ccccccccccccccccccccccccccccccccccccccccc compute lateral boundary conditions ccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then do j=1,mp zs(1,j)= zs(2,j) zh(1,j)= zh(2,j) enddo endif if (rightedge.eq.1) then do j=1,mp zs(np,j)= zs(np-1,j) zh(np,j)= zh(np-1,j) enddo endif endif if(ibcx.eq.1) then call updatelr(zs,np,mp,1,np,mp,1) call updatelr(zh,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp zs(np,j)= zs(np+1,j) zh(np,j)= zh(np+1,j) enddo endif endif if(ibcy.eq.0 )then if (botedge.eq.1) then do i=1,np zs(i,1)= zs(i,1+j3) zh(i,1)= zh(i,1+j3) enddo endif if (topedge.eq.1) then do i=1,np zs(i,mp)= zs(i,mp-j3) zh(i,mp)= zh(i,mp-j3) enddo endif endif if(ibcy.eq.1) then call updatebt(zs,np,mp,1,np,mp,1) call updatebt(zh,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np zs(i,mp)= zs(i,mp+1) zh(i,mp)= zh(i,mp+1) enddo endif endif #endif call update(zs,np,mp,1,np,mp,iup) call update(zh,np,mp,1,np,mp,iup) if(tt.le.tend) then #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then do j=1,mp zsd(1,j)= zsd(2,j) zhd(1,j)= zhd(2,j) enddo endif if (rightedge.eq.1) then do j=1,mp zsd(np,j)= zsd(np-1,j) zhd(np,j)= zhd(np-1,j) enddo endif endif if(ibcx.eq.1) then call updatelr(zsd,np,mp,1,np,mp,1) call updatelr(zhd,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp zsd(np,j)= zsd(np+1,j) zhd(np,j)= zhd(np+1,j) enddo endif endif if(ibcy.eq.0 )then if (botedge.eq.1) then do i=1,np zsd(i,1)= zsd(i,1+j3) zhd(i,1)= zhd(i,1+j3) enddo endif if (topedge.eq.1) then do i=1,np zsd(i,mp)= zsd(i,mp-j3) zhd(i,mp)= zhd(i,mp-j3) enddo endif endif if(ibcy.eq.1) then call updatebt(zsd,np,mp,1,np,mp,1) call updatebt(zhd,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np zsd(i,mp)= zsd(i,mp+1) zhd(i,mp)= zhd(i,mp+1) enddo endif endif #endif call update(zsd,np,mp,1,np,mp,iup) call update(zhd,np,mp,1,np,mp,iup) endif #if (PARALLEL == 0) iprint=0 if(iprint.eq.1) then if (leftedge.eq.1) then do j=1,mp ja=(mpos-1)*mp + j print *,'L:',ja,xr1(j),xc1(j) c print *,'L:',ja,xr1(j),xc1(j),yyy(j) enddo endif if (rightedge.eq.1) then do j=1,mp ja=(mpos-1)*mp + j print *,'R:',ja,xr2(j),xc2(j) enddo endif if (botedge.eq.1) then do i=1,np ia=(npos-1)*np + i print *,'B:',ia,yr1(i),yc1(i) enddo endif if (topedge.eq.1) then do i=1,np ia=(npos-1)*np + i print *,'T:',ia,yr2(i),yc2(i) enddo endif if(mype.eq.0) then print*,' zs(i,1)' write(6,990) (zs(i,1),i=1,np) print*,' zs(np,j)' write(6,990) (zs(np,j),j=1,mp) print*,' zh(i,1)' write(6,990) (zh(i,1),i=1,np) print*,' zh(np,j)' write(6,990) (zh(np,j),j=1,mp) print*,' xcr(i,1)' write(6,990) (xcr(i,1),i=1,np) print*,' xcr(np,j)' write(6,990) (xcr(np,j),j=1,mp) print*,' ycr(i,1)' write(6,990) (ycr(i,1),i=1,np) print*,' ycr(np,j)' write(6,990) (ycr(np,j),j=1,mp) print*,' cosa(i,1)' write(6,990) (cosa(i,1),i=1,np) print*,' cosa(np,j)' write(6,990) (cosa(np,j),j=1,mp) 990 format(2x,10(e15.7,1x)) end if end if #endif #if (TIMEPLT == 1) call ttend(6) #endif return end subroutine readtopo0(datarr,tmparray,tapearray,array,n1,m1) c c This subroutine reads topo from the file. c include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih), ! final parallel topo . tmparray(np,mp), ! tmp parallel array . tapearray(n1,m1), ! topo on tape . array( n, m) ! topo on full domain common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 c----------------------------------- c read ascii data c----------------------------------- c do i=1,n1 c do j=1,m1 c read(13) tapearray(i,j) c end do c end do do i=1,n1 read(13,*) (tapearray(i,j), j=1,m1) enddo c------------------------------------------------------------ c interpolate topography from tape array if bad dimension c------------------------------------------------------------ if((n1.eq.n).and.(m1.eq.m)) then do j=1,m do i=1,n c array(i,j)=tapearray(i,j) array(i,j)=amin1(tapearray(i,j), zb-5*dz) end do end do else if ((n1.ne.n).or.(m1.ne.m)) then c put here interpolation procedure endif c------------------------------------------------------------ c transfer processor 0 data from big array to local array c------------------------------------------------------------ do j=1,mp do i=1,np datarr(i,j)=array(i,j) end do end do #if (PARALLEL > 0) c loop over all other processors, sending them their data do iproc=1,(nprocx*nprocy - 1) npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do j=1,mp do i=1,np tmparray(i,j) = . array(((npos1-1)*np + i), ((mpos1-1)*mp + j)) end do end do nmp=np*mp #if (PARALLEL == 2) call MPI_Send(tmparray, nmp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif end do close #endif (PARALLEL > 0) #endif return end subroutine readtopok(datarr,tmparray) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih), . tmparray(np,mp) #if (PARALLEL > 0) c receive data from pe 0 nmp=np*mp #if (PARALLEL == 2) call MPI_Recv(tmparray, nmp, DC_TYPE, 0, 98, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif c transfer data to regular array do j=1,mp do i=1,np datarr(i,j)=tmparray(i,j) end do end do #endif return end ccccccccccccccccccccccccccccccccccccccccc subroutine metryc(x,y,z) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' include 'vrtstr.mds' dimension x(n),y(m),z(l) real esxb(np,mp),esyb(np,mp),dsxb(np,mp),dsyb(np,mp) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/stretchpar/ SS common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst #include "vrtstr.fnc" c fs(zo)=(1.-exp(-zo/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zo)=zo c fsi(zt)=zt #if (TIMEPLT == 1) call ttbeg(7) #endif ccccccccccccccccccccccccccccccccc c --- compute vertical stretching ccccccccccccccccccccccccccccccccc pi=acos(-1.) pirds = pi*rds pi2rds =2*pi*rds c SD=7000. SS=zb/fs(zb) SS=1. iprint=1 c if(mype.eq.0.and.iprint.eq.1) print 276,SS,zb,SD c 276 format(2x,'Stretching function parameters: ss,zb,sd:',3e11.4) do 1 j=1,mp do 1 i=1,np 1 gi(i,j)=zb/(zh(i,j)-zs(i,j)) c if(mype.eq.0.and.iprint.eq.1) print 4 do 2 k=1,l !GGstr: stretiching Chan&Sofia !next is eq (12) in the notes ! gmus(k) = SD*(rds+zb*fs(z(k)))**2/(log(1.+SD)*(SD*fs(z(k))+1.) * ! & (rds*(zb+rds))) ! zstr(k)=fs(z(k)) gmus(k)=(SS-z(k))/SD*istr+float(1-istr) zstr(k)=fsi(z(k)) gmul(k)=(zb-zstr(k)) if(icylind.eq.1) then do 333 j=1,mp do 333 i=1,np ia=(npos-1)*np + i 333 gmm(i,j,k)=rdsi*(x(ia)+rds) else do 3 j=1,mp do 3 i=1,np zcrl=zstr(k)/gi(i,j)+zs(i,j) 3 gmm(i,j,k)=1.+isphere*zcrl/rds endif !icylind c if(mype.eq.0.and.iprint.eq.1) c . print 5,k,z(k),fsi(z(k)),fs(z(k)),gmul(k),gmus(k) 2 continue 4 format(6x,'k',7x,'z',8x,'fsi',9x,'fs',9x,'gmul',9x,'gmus') 5 format(2x,i5,2x,f8.2,2x,f8.2,2x,f12.9,2x,f11.2,2x,f8.4) call update( gi,np,mp,1,np,mp,2) call update(gmm,np,mp,l,np,mp,iup) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- compute Jacobi and inverse Jacobi matrix elements ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge dx0=dxi*0.5 dy0=dyi*0.5 do i=illim,iulim c --- interior points do j=jllim,julim c --- compute dX/dXb esxb(i,j)=(xcr(i+1, j )-xcr(i-1, j ))*dx0 ! dx/d(xb) esyb(i,j)=(xcr( i ,j+j3)-xcr( i ,j-j3))*dy0 ! dx/d(yb) estb=0. ! dx/d(tb) dsxb(i,j)=(ycr(i+1, j )-ycr(i-1, j ))*dx0 ! dy/d(xb) dsyb(i,j)=(ycr( i ,j+j3)-ycr( i ,j-j3))*dy0 ! dy/d(yb) . +float(1-j3) dstb=0. ! dy/d(tb) c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,j)*esxb(i,j)-dsxb(i,j)*esyb(i,j)) strxx(i,j)= dsyb(i,j)*den ! d(xb)/dx strxy(i,j)=-esyb(i,j)*den ! d(xb)/dy strxd(i,j)=(dstb*esyb(i,j)-dsyb(i,j)*estb)*den ! d(xb)/dt stryx(i,j)=-dsxb(i,j)*den ! d(yb)/dx stryy(i,j)= esxb(i,j)*den ! d(yb)/dy stryd(i,j)=(estb*dsxb(i,j)-esxb(i,j)*dstb)*den ! d(yb)/dt ! if(stryy(i,j).lt.0) print*,'STRYY:',stryy(i,j), ! . i,j,den,dsyb,esxb,dsxb,esyb,ycr(i,j-1),ycr(i,j),ycr(i,j+1) enddo enddo #if (POLES == 0) if (botedge.eq.1) then c --- Southern boundary region j=1 c --- compute dX/dXb do 11 i=illim,iulim esxb(i,1)= (xcr(i+1,1 )-xcr(i-1, 1 ))*dx0 esyb(i,1)=(1-ibcy)*(xcr(i ,1+j3)-xcr(i , 1 ))*dyi * +ibcy *(xcr(i ,1+j3)-xcr(i ,-j3))*dy0 estb=0. dsxb(i,1)= (ycr(i+1,1 )-ycr(i-1, 1 ))*dx0 dsyb(i,1)=(1-ibcy)*(ycr(i ,1+j3)-ycr(i , 1 ))*dyi * +ibcy*(ycr(i ,1+j3)-ycr(i ,-j3)+ * ycr(i ,0 )-ycr(i , 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,1)*esxb(i,1)-dsxb(i,1)*esyb(i,1)) strxx(i,1)= dsyb(i,1)*den strxy(i,1)=-esyb(i,1)*den strxd(i,1)=(dstb*esyb(i,1)-dsyb(i,1)*estb)*den stryx(i,1)=-dsxb(i,1)*den stryy(i,1)= esxb(i,1)*den 11 stryd(i,1)=(estb*dsxb(i,1)-esxb(i,1)*dstb)*den end if if (topedge.eq.1) then c --- Northern boundary region c --- compute dX/dXb do 12 i=illim,iulim esxb(i,mp)= (xcr(i+1,mp )-xcr(i-1,mp ))*dx0 esyb(i,mp)=(1-ibcy)*(xcr(i ,mp )-xcr(i ,mp-j3))*dyi * +ibcy *(xcr(i ,mp+1+j3)-xcr(i ,mp-j3))*dy0 estb=0. dsxb(i,mp)= (ycr(i+1,mp )-ycr(i-1,mp ))*dx0 dsyb(i,mp)=(1-ibcy)*(ycr(i ,mp )-ycr(i ,mp-j3))*dyi * +ibcy*(ycr(i ,mp+1+j3)-ycr(i ,mp-j3)+ * ycr(i ,mp )-ycr(i ,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,mp)*esxb(i,mp)-dsxb(i,mp)*esyb(i,mp)) strxx(i,mp)= dsyb(i,mp)*den strxy(i,mp)=-esyb(i,mp)*den strxd(i,mp)=(dstb*esyb(i,mp)-dsyb(i,mp)*estb)*den stryx(i,mp)=-dsxb(i,mp)*den stryy(i,mp)= esxb(i,mp)*den 12 stryd(i,mp)=(estb*dsxb(i,mp)-esxb(i,mp)*dstb)*den end if #else if (botedge.eq.1) then c --- Southern boundary region j=1, flow over the Southern Pole c --- compute dX/dXb do 11 i=illim,iulim esxb(i,1)=(xcr(i+1,1 )- xcr(i-1, 1 ))*dx0 c esyb(i,1)=(xcr(i ,1+j3)-(xcr(i ,1-j3)-pirds))*dy0 esyb(i,1)=(xcr(i ,1+j3)-xcr(i ,1-j3))*dy0 estb=0. dsxb(i,1)=(ycr(i+1,1 )-ycr(i-1, 1 ))*dx0 dsyb(i,1)=(ycr(i ,1+j3)+ycr(i ,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,1)*esxb(i,1)-dsxb(i,1)*esyb(i,1)) strxx(i,1)= dsyb(i,1)*den strxy(i,1)=-esyb(i,1)*den strxd(i,1)=(dstb*esyb(i,1)-dsyb(i,1)*estb)*den stryx(i,1)=-dsxb(i,1)*den stryy(i,1)= esxb(i,1)*den 11 stryd(i,1)=(estb*dsxb(i,1)-esxb(i,1)*dstb)*den end if if (topedge.eq.1) then c --- Northern boundary region, flow over the Northern Pole c --- compute dX/dXb do 12 i=illim,iulim esxb(i,mp)=( xcr(i+1,mp ) -xcr(i-1,mp ))*dx0 c esyb(i,mp)=((xcr(i ,mp+j3)-pirds)-xcr(i ,mp-j3))*dy0 esyb(i,mp)=(xcr(i ,mp+j3)-xcr(i ,mp-j3))*dy0 estb=0. dsxb(i,mp)= (ycr(i+1,mp )-ycr(i-1,mp ))*dx0 dsyb(i,mp)=(pirds-ycr(i ,mp+j3)-ycr(i ,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,mp)*esxb(i,mp)-dsxb(i,mp)*esyb(i,mp)) strxx(i,mp)= dsyb(i,mp)*den strxy(i,mp)=-esyb(i,mp)*den strxd(i,mp)=(dstb*esyb(i,mp)-dsyb(i,mp)*estb)*den stryx(i,mp)=-dsxb(i,mp)*den stryy(i,mp)= esxb(i,mp)*den 12 stryd(i,mp)=(estb*dsxb(i,mp)-esxb(i,mp)*dstb)*den end if #endif #if (POLES == 0) if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region c --- compute dX/dXb esxb(1,j)=(1-ibcx)*(xcr(2,j )-xcr( 1,j ))*dxi * +ibcx *(xcr(2,j )-xcr(-1,j )+ * xcr(0,j )-xcr( 1,j ))*dx0 esyb(1,j)= (xcr(1,j+j3)-xcr( 1,j-j3))*dy0 estb=0. dsxb(1,j)=(1-ibcx)*(ycr(2,j )-ycr( 1,j ))*dxi * +ibcx *(ycr(2,j )-ycr(-1,j ))*dx0 dsyb(1,j)= (ycr(1,j+j3)-ycr( 1,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,j)*esxb(1,j)-dsxb(1,j)*esyb(1,j)) strxx(1,j)= dsyb(1,j)*den strxy(1,j)=-esyb(1,j)*den strxd(1,j)=(dstb*esyb(1,j)-dsyb(1,j)*estb)*den stryx(1,j)=-dsxb(1,j)*den stryy(1,j)= esxb(1,j)*den stryd(1,j)=(estb*dsxb(1,j)-esxb(1,j)*dstb)*den enddo end if if (rightedge.eq.1) then do j=jllim,julim c --- Eastern boundary region c --- compute dX/dXb esxb(np,j)=(1-ibcx)*(xcr(np ,j )-xcr(np-1,j ))*dxi * +ibcx *(xcr(np+2,j )-xcr(np-1,j )+ * xcr(np ,j )-xcr(np+1,j ))*dx0 esyb(np,j)= (xcr(np ,j+j3)-xcr(np ,j-j3))*dy0 estb=0. dsxb(np,j)=(1-ibcx)*(ycr(np ,j )-ycr(np-1,j ))*dxi * +ibcx *(ycr(np+2,j )-ycr(np-1,j ))*dx0 dsyb(np,j)= (ycr(np ,j+j3)-ycr(np ,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,j)*esxb(np,j)-dsxb(np,j)*esyb(np,j)) strxx(np,j)= dsyb(np,j)*den strxy(np,j)=-esyb(np,j)*den strxd(np,j)=(dstb*esyb(np,j)-dsyb(np,j)*estb)*den stryx(np,j)=-dsxb(np,j)*den stryy(np,j)= esxb(np,j)*den stryd(np,j)=(estb*dsxb(np,j)-esxb(np,j)*dstb)*den enddo end if #else if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region c --- compute dX/dXb c esxb(1,j)=(xcr(2,j )-(xcr(0,j )-pi2rds))*dx0 esxb(1,j)=(xcr(2,j )-xcr(0,j ))*dx0 esyb(1,j)=(xcr(1,j+j3)- xcr(1,j-j3))*dy0 estb=0. dsxb(1,j)=(ycr(2,j )-ycr(0,j ))*dx0 dsyb(1,j)=(ycr(1,j+j3)-ycr(1,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,j)*esxb(1,j)-dsxb(1,j)*esyb(1,j)) strxx(1,j)= dsyb(1,j)*den strxy(1,j)=-esyb(1,j)*den strxd(1,j)=(dstb*esyb(1,j)-dsyb(1,j)*estb)*den stryx(1,j)=-dsxb(1,j)*den stryy(1,j)= esxb(1,j)*den stryd(1,j)=(estb*dsxb(1,j)-esxb(1,j)*dstb)*den enddo end if if (rightedge.eq.1) then do j=jllim,julim c --- Eastern boundary region c --- compute dX/dXb c esxb(np,j)=((xcr(np+1,j)+pi2rds)-xcr(np-1,j))*dx0 esxb(np,j)=(xcr(np+1,j)-xcr(np-1,j))*dx0 esyb(np,j)=(xcr(np ,j+j3)-xcr(np ,j-j3))*dy0 estb=0. dsxb(np,j)=(ycr(np+1,j )-ycr(np-1,j ))*dx0 dsyb(np,j)=(ycr(np ,j+j3)-ycr(np ,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,j)*esxb(np,j)-dsxb(np,j)*esyb(np,j)) strxx(np,j)= dsyb(np,j)*den strxy(np,j)=-esyb(np,j)*den strxd(np,j)=(dstb*esyb(np,j)-dsyb(np,j)*estb)*den stryx(np,j)=-dsxb(np,j)*den stryy(np,j)= esxb(np,j)*den stryd(np,j)=(estb*dsxb(np,j)-esxb(np,j)*dstb)*den enddo end if #endif #if (POLES == 0) if (botedge.eq.1) then if (leftedge.eq.1) then C --- SW corner c --- compute dX/dXb esxb(1,1)=(1-ibcx)*(xcr(2,1 )-xcr( 1, 1 ))*dxi * +ibcx *(xcr(2,1 )-xcr(-1, 1 )+ * xcr(0,1 )-xcr( 1, 1 ))*dx0 esyb(1,1)=(1-ibcy)*(xcr(1,1+j3)-xcr( 1, 1 ))*dyi * +ibcy *(xcr(1,1+j3)-xcr( 1,-j3))*dy0 estb=0. dsxb(1,1)=(1-ibcx)*(ycr(2,1 )-ycr( 1, 1 ))*dxi * +ibcx *(ycr(2,1 )-ycr(-1, 1 ))*dx0 dsyb(1,1)=(1-ibcy)*(ycr(1,1+j3)-ycr( 1, 1 ))*dyi * +ibcy *(ycr(1,1+j3)-ycr( 1,-j3)+ * ycr(1,0 )-ycr( 1, 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,1)*esxb(1,1)-dsxb(1,1)*esyb(1,1)) strxx(1,1)= dsyb(1,1)*den strxy(1,1)=-esyb(1,1)*den strxd(1,1)=(dstb*esyb(1,1)-dsyb(1,1)*estb)*den stryx(1,1)=-dsxb(1,1)*den stryy(1,1)= esxb(1,1)*den stryd(1,1)=(estb*dsxb(1,1)-esxb(1,1)*dstb)*den endif if(rightedge.eq.1) then C --- SE corner c --- compute dX/dXb esxb(np,1)=(1-ibcx)*(xcr(np ,1 )-xcr(np-1, 1 ))*dxi * +ibcx *(xcr(np+2,1 )-xcr(np-1, 1 )+ * xcr(np ,1 )-xcr(np+1, 1 ))*dx0 esyb(np,1)=(1-ibcy)*(xcr(np ,1+j3)-xcr(np , 1 ))*dyi * +ibcy *(xcr(np ,1+j3)-xcr(np ,-j3))*dy0 estb=0. dsxb(np,1)=(1-ibcx)*(ycr(np ,1 )-ycr(np-1, 1 ))*dxi * +ibcx *(ycr(np+2,1 )-ycr(np-1, 1 ))*dx0 dsyb(np,1)=(1-ibcy)*(ycr(np ,1+j3)-ycr(np , 1 ))*dyi * +ibcy *(ycr(np ,1+j3)-ycr(np ,-j3) * +ycr(np ,0 )-ycr(np , 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,1)*esxb(np,1)-dsxb(np,1)*esyb(np,1)) strxx(np,1)= dsyb(np,1)*den strxy(np,1)=-esyb(np,1)*den strxd(np,1)=(dstb*esyb(np,1)-dsyb(np,1)*estb)*den stryx(np,1)=-dsxb(np,1)*den stryy(np,1)= esxb(np,1)*den stryd(np,1)=(estb*dsxb(np,1)-esxb(np,1)*dstb)*den endif endif if (topedge.eq.1) then if (rightedge.eq.1) then C --- NE corner c --- compute dX/dXb esxb(np,mp)=(1-ibcx)*(xcr(np ,mp )-xcr(np-1,mp ))*dxi * +ibcx *(xcr(np+2,mp )-xcr(np-1,mp ) * +xcr(np ,mp )-xcr(np+1,mp ))*dx0 esyb(np,mp)=(1-ibcy)*(xcr(np ,mp )-xcr(np ,mp-j3))*dyi * +ibcy *(xcr(np ,mp+1+j3)-xcr(np ,mp-j3))*dy0 estb=0. dsxb(np,mp)=(1-ibcx)*(ycr(np ,mp )-ycr(np-1,mp ))*dxi * +ibcx *(ycr(np+2,mp )-ycr(np-1,mp ))*dx0 dsyb(np,mp)=(1-ibcy)*(ycr(np ,mp )-ycr(np ,mp-j3))*dyi * +ibcy *(ycr(np ,mp+1+j3)-ycr(np ,mp-j3)+ * ycr(np ,mp )-ycr(np ,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,mp)*esxb(np,mp)-dsxb(np,mp)*esyb(np,mp)) strxx(np,mp)= dsyb(np,mp)*den strxy(np,mp)=-esyb(np,mp)*den strxd(np,mp)=(dstb*esyb(np,mp)-dsyb(np,mp)*estb)*den stryx(np,mp)=-dsxb(np,mp)*den stryy(np,mp)= esxb(np,mp)*den stryd(np,mp)=(estb*dsxb(np,mp)-esxb(np,mp)*dstb)*den endif if(leftedge.eq.1) then C --- NW corner c --- compute dX/dXb esxb(1,mp)=(1-ibcx)*(xcr(2,mp )-xcr( 1,mp ))*dxi * +ibcx *(xcr(2,mp )-xcr(-1,mp )+ * xcr(0,mp )-xcr( 1,mp ))*dx0 esyb(1,mp)=(1-ibcy)*(xcr(1,mp )-xcr( 1,mp-j3))*dyi * +ibcy *(xcr(1,mp+1+j3)-xcr( 1,mp-j3))*dy0 estb=0. dsxb(1,mp)=(1-ibcx)*(ycr(2,mp )-ycr( 1,mp ))*dxi * +ibcx *(ycr(2,mp )-ycr(-1,mp ))*dx0 dsyb(1,mp)=(1-ibcy)*(ycr(1,mp )-ycr( 1,mp-j3))*dyi * +ibcy *(ycr(1,mp+1+j3)-ycr( 1,mp-j3)+ * ycr(1,mp )-ycr( 1,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,mp)*esxb(1,mp)-dsxb(1,mp)*esyb(1,mp)) strxx(1,mp)= dsyb(1,mp)*den strxy(1,mp)=-esyb(1,mp)*den strxd(1,mp)=(dstb*esyb(1,mp)-dsyb(1,mp)*estb)*den stryx(1,mp)=-dsxb(1,mp)*den stryy(1,mp)= esxb(1,mp)*den stryd(1,mp)=(estb*dsxb(1,mp)-esxb(1,mp)*dstb)*den endif endif #else if (botedge.eq.1) then if (leftedge.eq.1) then C --- SW corner c --- compute dX/dXb c esxb(1,1)=(xcr(2,1 )-(xcr(0, 1 )-pi2rds))*dx0 esxb(1,1)=(xcr(2,1 )-xcr(0, 1 ))*dx0 c esyb(1,1)=(xcr(1,1+j3)-(xcr(1,1-j3)-pirds))*dy0 esyb(1,1)=(xcr(1,1+j3)-xcr(1,1-j3))*dy0 estb=0. dsxb(1,1)=(ycr(2,1 )-ycr(0, 1 ))*dx0 dsyb(1,1)=(ycr(1,1+j3)+ycr(1,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,1)*esxb(1,1)-dsxb(1,1)*esyb(1,1)) strxx(1,1)= dsyb(1,1)*den strxy(1,1)=-esyb(1,1)*den strxd(1,1)=(dstb*esyb(1,1)-dsyb(1,1)*estb)*den stryx(1,1)=-dsxb(1,1)*den stryy(1,1)= esxb(1,1)*den stryd(1,1)=(estb*dsxb(1,1)-esxb(1,1)*dstb)*den endif if(rightedge.eq.1) then C --- SE corner c --- compute dX/dXb c esxb(np,1)=((xcr(np+1,1 )+pi2rds)-xcr(np-1, 1 ))*dx0 esxb(np,1)=(xcr(np+1,1)-xcr(np-1,1))*dx0 c esyb(np,1)=( xcr(np ,1+j3)-(xcr(np ,1-j3)-pirds))*dy0 esyb(np,1)=( xcr(np ,1+j3)- xcr(np ,1-j3))*dy0 estb=0. dsxb(np,1)=(ycr(np+1,1 )-ycr(np-1, 1 ))*dx0 dsyb(np,1)=(ycr(np ,1+j3)+ycr(np ,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,1)*esxb(np,1)-dsxb(np,1)*esyb(np,1)) strxx(np,1)= dsyb(np,1)*den strxy(np,1)=-esyb(np,1)*den strxd(np,1)=(dstb*esyb(np,1)-dsyb(np,1)*estb)*den stryx(np,1)=-dsxb(np,1)*den stryy(np,1)= esxb(np,1)*den stryd(np,1)=(estb*dsxb(np,1)-esxb(np,1)*dstb)*den endif endif if (topedge.eq.1) then if (rightedge.eq.1) then C --- NE corner c --- compute dX/dXb c esxb(np,mp)=((xcr(np+1,mp)+pi2rds)-xcr(np-1,mp ))*dx0 esxb(np,mp)=(xcr(np+1,mp)-xcr(np-1,mp))*dx0 c esyb(np,mp)=((xcr(np,mp+j3)-pirds)-xcr(np,mp-j3))*dy0 esyb(np,mp)=( xcr(np,mp+j3)-xcr(np,mp-j3))*dy0 estb=0. dsxb(np,mp)=(ycr(np+1,mp )-ycr(np-1,mp ))*dx0 dsyb(np,mp)=(pirds-ycr(np,mp+j3)-ycr(np,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,mp)*esxb(np,mp)-dsxb(np,mp)*esyb(np,mp)) strxx(np,mp)= dsyb(np,mp)*den strxy(np,mp)=-esyb(np,mp)*den strxd(np,mp)=(dstb*esyb(np,mp)-dsyb(np,mp)*estb)*den stryx(np,mp)=-dsxb(np,mp)*den stryy(np,mp)= esxb(np,mp)*den stryd(np,mp)=(estb*dsxb(np,mp)-esxb(np,mp)*dstb)*den endif if(leftedge.eq.1) then C --- NW corner c --- compute dX/dXb c esxb(1,mp)=( xcr(2,mp )-(xcr(0,mp )-pi2rds))*dx0 esxb(1,mp)=(xcr(2,mp )-xcr(0,mp ))*dx0 c esyb(1,mp)=((xcr(1,mp+j3)-pirds)-xcr(1,mp-j3))*dy0 esyb(1,mp)=( xcr(1,mp+j3)-xcr(1,mp-j3))*dy0 estb=0. dsxb(1,mp)=(ycr(2,mp )-ycr(0,mp ))*dx0 dsyb(1,mp)=(pirds-ycr(1,mp+j3)-ycr(1,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,mp)*esxb(1,mp)-dsxb(1,mp)*esyb(1,mp)) strxx(1,mp)= dsyb(1,mp)*den strxy(1,mp)=-esyb(1,mp)*den strxd(1,mp)=(dstb*esyb(1,mp)-dsyb(1,mp)*estb)*den stryx(1,mp)=-dsxb(1,mp)*den stryy(1,mp)= esxb(1,mp)*den stryd(1,mp)=(estb*dsxb(1,mp)-esxb(1,mp)*dstb)*den endif endif #endif #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcx.eq.1) then call updatelr(strxx,np,mp,1,np,mp,1) call updatelr(strxy,np,mp,1,np,mp,1) call updatelr(stryx,np,mp,1,np,mp,1) call updatelr(stryy,np,mp,1,np,mp,1) call updatelr(strxd,np,mp,1,np,mp,1) call updatelr(stryd,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp strxx(np,j)= strxx(np+1,j) strxy(np,j)= strxy(np+1,j) stryx(np,j)= stryx(np+1,j) stryy(np,j)= stryy(np+1,j) strxd(np,j)= strxd(np+1,j) stryd(np,j)= stryd(np+1,j) enddo endif endif if(ibcy.eq.1) then call updatebt(strxx,np,mp,1,np,mp,1) call updatebt(strxy,np,mp,1,np,mp,1) call updatebt(stryx,np,mp,1,np,mp,1) call updatebt(stryy,np,mp,1,np,mp,1) call updatebt(strxd,np,mp,1,np,mp,1) call updatebt(stryd,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np strxx(i,mp)= strxx(i,mp+1) strxy(i,mp)= strxy(i,mp+1) stryx(i,mp)= stryx(i,mp+1) stryy(i,mp)= stryy(i,mp+1) strxd(i,mp)= strxd(i,mp+1) stryd(i,mp)= stryd(i,mp+1) enddo endif endif endif #endif call update(strxx,np,mp,1,np,mp,iup) call update(strxy,np,mp,1,np,mp,iup) call update(stryx,np,mp,1,np,mp,iup) call update(stryy,np,mp,1,np,mp,iup) call update(strxd,np,mp,1,np,mp,iup) call update(stryd,np,mp,1,np,mp,iup) cccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- compute gradients of zs for g13, g23 coefficients c --- S. polar region c --- N. polar region c --- ip(i) points are just present inside ghost array area c in the appriopriate place: update(gi,np,mp,1,np,mp) c --- periodicity in x is never enforced cccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #endif c----------------------------------------------------------------- c --- Additional vertical metric coefficients: c --- Compute gradients of zs,zh for g13, g23 coefficients. c --- NOTE: Partially satisfy GCL here and use KD identities! c----------------------------------------------------------------- do i=illim,iulim c --- interior points do j=jllim,julim zsxb=dx0*(1./gi(i+1,j )-1./gi(i-1,j ))*gi(i,j) !zsxb/(H-zs) zsyb=dy0*(1./gi(i,j+j3)-1./gi(i,j-j3))*gi(i,j) !zsyb/(H-zs) zhxb=dx0*(zh(i+1, j)-zh(i-1, j))*gi(i,j) !zhxb/G zhyb=dy0*(zh(i,j+j3)-zh(i,j-j3))*gi(i,j) !zhyb/G s13(i,j)=strxx(i,j)*zsxb+stryx(i,j)*zsyb s23(i,j)=strxy(i,j)*zsxb+stryy(i,j)*zsyb h13(i,j)=strxx(i,j)*zhxb+stryx(i,j)*zhyb 21 h23(i,j)=strxy(i,j)*zhxb+stryy(i,j)*zhyb enddo enddo #if (POLES == 0) if (botedge.eq.1) then do i=illim,iulim c --- Southern boundary region zsxb= dx0*(1./gi(i+1,1 )-1./gi(i-1,1))*gi(i,1) zsyb=ibcy*dy0*(1./gi(i,1+j3)-1./gi(i,-j3))*gi(i,1) zhxb= dx0*(zh(i+1, 1)-zh(i-1, 1))*gi(i,1) zhyb=ibcy*dy0*(zh(i,1+j3)-zh(i,-j3))*gi(i,1) s13(i,1)=strxx(i,1)*zsxb+stryx(i,1)*zsyb s23(i,1)=strxy(i,1)*zsxb+stryy(i,1)*zsyb h13(i,1)=strxx(i,1)*zhxb+stryx(i,1)*zhyb h23(i,1)=strxy(i,1)*zhxb+stryy(i,1)*zhyb enddo endif if (topedge.eq.1) then do i=illim,iulim c --- Northern boundary region zsxb= dx0*(1./gi(i+1,mp )-1./gi(i-1,mp))*gi(i,mp) zsyb=ibcy*dy0*(1./gi(i,mp+1+j3)-1./gi(i,mp-j3))*gi(i,mp) zhxb= dx0*(zh(i+1, mp)-zh(i-1, mp))*gi(i,mp) zhyb=ibcy*dy0*(zh(i,mp+1+j3)-zh(i,mp-j3))*gi(i,mp) s13(i,mp)=strxx(i,mp)*zsxb+stryx(i,mp)*zsyb s23(i,mp)=strxy(i,mp)*zsxb+stryy(i,mp)*zsyb h13(i,mp)=strxx(i,mp)*zhxb+stryx(i,mp)*zhyb h23(i,mp)=strxy(i,mp)*zhxb+stryy(i,mp)*zhyb enddo endif #else if (botedge.eq.1) then do i=1,np c --- Southern boundary region zsxb= dx0*(1./gi(i+1,1 )-1./gi(i-1,1))*gi(i,1) zsyb=ibcy*dy0*(1./gi(i,1+j3)-1./gi(i,1-j3))*gi(i,1) zhxb= dx0*(zh(i+1, 1)-zh(i-1, 1))*gi(i,1) zhyb=ibcy*dy0*(zh(i,1+j3)-zh(i,1-j3))*gi(i,1) s13(i,1)=strxx(i,1)*zsxb+stryx(i,1)*zsyb s23(i,1)=strxy(i,1)*zsxb+stryy(i,1)*zsyb h13(i,1)=strxx(i,1)*zhxb+stryx(i,1)*zhyb h23(i,1)=strxy(i,1)*zhxb+stryy(i,1)*zhyb enddo endif if (topedge.eq.1) then do i=1,np c --- Northern boundary region zsxb= dx0*(1./gi(i+1,mp )-1./gi(i-1,mp))*gi(i,mp) zsyb=ibcy*dy0*(1./gi(i,mp+j3)-1./gi(i,mp-j3))*gi(i,mp) zhxb= dx0*(zh(i+1, mp)-zh(i-1, mp))*gi(i,mp) zhyb=ibcy*dy0*(zh(i,mp+j3)-zh(i,mp-j3))*gi(i,mp) s13(i,mp)=strxx(i,mp)*zsxb+stryx(i,mp)*zsyb s23(i,mp)=strxy(i,mp)*zsxb+stryy(i,mp)*zsyb h13(i,mp)=strxx(i,mp)*zhxb+stryx(i,mp)*zhyb h23(i,mp)=strxy(i,mp)*zhxb+stryy(i,mp)*zhyb enddo endif #endif #if (POLES == 0) if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region zsxb=ibcx*dx0*(1./gi(2,j )-1./gi(-1,j ))*gi(1,j) !zsxb/(H-zs) zsyb= dy0*(1./gi(1,j+j3)-1./gi( 1,j-j3))*gi(1,j) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,j)-zh(-1,j))*gi(1,j) !zhxb/G zhyb= dy0*(zh(1,j+j3)-zh(1,j-j3))*gi(1,j) !zhyb/G s13(1,j)=strxx(1,j)*zsxb+stryx(1,j)*zsyb s23(1,j)=strxy(1,j)*zsxb+stryy(1,j)*zsyb h13(1,j)=strxx(1,j)*zhxb+stryx(1,j)*zhyb h23(1,j)=strxy(1,j)*zhxb+stryy(1,j)*zhyb enddo endif if (rightedge.eq.1) then do j=jllim,julim c --- Estern boundary region zsxb=ibcx*dx0*(1./gi(np+2,j )-1./gi(np-1,j ))*gi(np,j) !zsxb/(H-zs) zsyb= dy0*(1./gi(np,j+j3)-1./gi(np,j-j3))*gi(np,j) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,j)-zh(np-1,j))*gi(np,j) !zhxb/G zhyb= dy0*(zh(np,j+j3)-zh(np,j-j3))*gi(np,j) !zhyb/G s13(np,j)=strxx(np,j)*zsxb+stryx(np,j)*zsyb s23(np,j)=strxy(np,j)*zsxb+stryy(np,j)*zsyb h13(np,j)=strxx(np,j)*zhxb+stryx(np,j)*zhyb h23(np,j)=strxy(np,j)*zhxb+stryy(np,j)*zhyb enddo endif if (rightedge.eq.1) then if (botedge.eq.1) then c --- ES corner zsxb=ibcx*dx0*(1./gi(np+2,1 )-1./gi(np-1,1))*gi(np,1) ! zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(np,1+j3)-1./gi(np,-j3))*gi(np,1) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,1)-zh(np-1,1))*gi(np,1) !zhxb/G zhyb=ibcy*dy0*(zh(np,1+j3)-zh(np,-j3))*gi(np,1) !zhyb/G s13(np,1)=strxx(np,1)*zsxb+stryx(np,1)*zsyb s23(np,1)=strxy(np,1)*zsxb+stryy(np,1)*zsyb h13(np,1)=strxx(np,1)*zhxb+stryx(np,1)*zhyb h23(np,1)=strxy(np,1)*zhxb+stryy(np,1)*zhyb endif if (topedge.eq.1) then c --- EN corner zsxb=ibcx*dx0*(1./gi(np+2,mp )-1./gi(np-1,mp ))*gi(np,mp) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(np,mp+1+j3)-1./gi(np,mp-j3))*gi(np,mp) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,mp)-zh(np-1,mp))*gi(np,mp) !zhxb/G zhyb=ibcy*dy0*(zh(np,mp+1+j3)-zh(np,mp-j3))*gi(np,mp) !zhyb/G s13(np,mp)=strxx(np,mp)*zsxb+stryx(np,mp)*zsyb s23(np,mp)=strxy(np,mp)*zsxb+stryy(np,mp)*zsyb h13(np,mp)=strxx(np,mp)*zhxb+stryx(np,mp)*zhyb h23(np,mp)=strxy(np,mp)*zhxb+stryy(np,mp)*zhyb endif endif if (leftedge.eq.1) then if (topedge.eq.1) then c --- WN corner zsxb=ibcx*dx0*(1./gi(2,mp )-1./gi(-1,mp ))*gi(1,mp) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(1,mp+1+j3)-1./gi( 1,mp-j3))*gi(1,mp) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,mp)-zh(-1,mp))*gi(1,mp) !zhxb/G zhyb=ibcy*dy0*(zh(1,mp+1+j3)-zh(1,mp-j3))*gi(1,mp) !zhyb/G s13(1,mp)=strxx(1,mp)*zsxb+stryx(1,mp)*zsyb s23(1,mp)=strxy(1,mp)*zsxb+stryy(1,mp)*zsyb h13(1,mp)=strxx(1,mp)*zhxb+stryx(1,mp)*zhyb h23(1,mp)=strxy(1,mp)*zhxb+stryy(1,mp)*zhyb endif if (botedge.eq.1) then c --- WS corner zsxb=ibcx*dx0*(1./gi(2,1 )-1./gi(-1, 1 ))*gi(1,1) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(1,1+j3)-1./gi( 1,-j3))*gi(1,1) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,1)-zh(-1,1))*gi(1,1) !zhxb/G zhyb=ibcy*dy0*(zh(1,1+j3)-zh(1,-j3))*gi(1,1) !zhyb/G s13(1,1)=strxx(1,1)*zsxb+stryx(1,1)*zsyb s23(1,1)=strxy(1,1)*zsxb+stryy(1,1)*zsyb h13(1,1)=strxx(1,1)*zhxb+stryx(1,1)*zhyb h23(1,1)=strxy(1,1)*zhxb+stryy(1,1)*zhyb endif endif #endif call update(s13,np,mp,1,np,mp,iup) call update(s23,np,mp,1,np,mp,iup) call update(h13,np,mp,1,np,mp,iup) call update(h23,np,mp,1,np,mp,iup) #if (TIMEPLT == 1) call ttend(7) #endif return end subroutine rhoswap(ind) include 'param.nml' include 'msg.inc' common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) if(ind.eq. 1) then do 1 k=1,l do 1 j=1,mp do 1 i=1,np rhstr(i,j,k)=rho(i,j,k) 1 rho(i,j,k)=rh0(i,j,k) call update(rho,np,mp,l,np,mp,iup) endif if(ind.eq.-1) then do 11 k=1,l do 11 j=1,mp do 11 i=1,np 11 rho(i,j,k)=rhstr(i,j,k) call update(rho,np,mp,l,np,mp,iup) endif return end ccccccccccccccccccccccccccccccccccccccccc subroutine vstrhat(ox,oy,oz,ind) ccccccccccccccccccccccccccccccccccccccccc c ind -1, from solenoidal to contravariant c ind +1, from contravariant to solenoidal include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(9) #endif corporate time dependent lower boundary into mass continuity equation: ind=+1 come back to original meaning of omega : ind=-1 zbi=1./zb do 1 k=1,l zsdcoe=ind*gmul(k)*zbi*gmus(k) zhdcoe=ind*(gmul(k)*zbi-1.)*gmus(k) do 1 j=1,mp do 1 i=1,np ox(i,j,k)=ox(i,j,k)-ind*strxd(i,j) oy(i,j,k)=oy(i,j,k)-ind*stryd(i,j) oz(i,j,k)=oz(i,j,k)+zsdcoe*zsd(i,j)*gi(i,j) . -zhdcoe*zhd(i,j)*gi(i,j) 1 continue c call update(ox,np,mp,l,np,mp,iup) c call update(oy,np,mp,l,np,mp,iup) c call update(oz,np,mp,l,np,mp,iup) #if (TIMEPLT == 1) call ttend(9) #endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES TOPOGRAPHY / GRID GEOMETRY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccc subroutine rhsdiv(u,v,w,d,r,iflg) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l), . r(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(12) #endif do 200 k=1,l do 200 j=1,mp do 200 i=1,np 200 r(i,j,k)=0. if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi call update(u,np,mp,l,np,mp,iupx) call update(d,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 r(i,j,k)=dxil*(u(i+1,j,k)*d(i+1,j,k)-u(i-1,j,k)*d(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*dxi*(u( 2,j,k)*d( 2,j,k) . -u( 1,j,k)*d( 1,j,k)) 2 +ibcx*dxil*(u( 2,j,k)*d( 2,j,k) . -u(-1,j,k)*d(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)*d(np ,j,k) . -u(np-1,j,k)*d(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)*d(np+2,j,k) . -u(np-1,j,k)*d(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then ! ANDII call updatebt(v,np,mp,l,np,mp,iupy) call updatebt(d,np,mp,l,np,mp,iupy) jllim = 1 + j3*botedge julim = mp - j3*topedge do 12 k=1,l do 12 j=jllim,julim do 12 i=1,np 12 r(i,j,k)=r(i,j,k) 2 +dyil*(v(i,j+j3,k)*d(i,j+j3,k)-v(i,j-j3,k)*d(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k) 1 +(1-ibcy)*dyi*(v(i,1+j3,k)*d(i,1+j3,k) . -v(i, 1 ,k)*d(i, 1 ,k)) 2 +ibcy*dyil*(v(i,1+j3,k)*d(i,1+j3,k) . -v(i,-1 ,k)*d(i,-1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k) 1 +(1-ibcy)*dyi*(v(i,mp ,k)*d(i,mp ,k) . -v(i,mp-j3,k)*d(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2 ,k)*d(i,mp+2 ,k) . -v(i,mp-j3,k)*d(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+dyil*( d(i,1+j3,k)*v(i,1+j3,k) ! . +d(i,1-j3,k)*v(i,1-j3,k)) r(i,1,k)=r(i,1,k)+dyil*( d(i,1+j3,k)*v(i,1+j3,k) . +d(i,1 ,k)*v(i,1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-dyil*( d(i,mp+j3,k)*v(i,mp+j3,k) ! . +d(i,mp-j3,k)*v(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-dyil*( d(i,mp ,k)*v(i,mp ,k) . +d(i,mp-j3,k)*v(i,mp-j3,k)) end do end do end if #endif endif ! ANDII do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 r(i,j,k)=r(i,j,k) 3 +dzil*(w(i,j,k+1)*d(i,j,k+1)-w(i,j,k-1)*d(i,j,k-1)) if(ibcz.eq.0) then do 13 j=1,mp do 13 i=1,np r(i,j,1)=r(i,j,1)+dzi*(w(i,j,2)*d(i,j,2)-w(i,j,1 )*d(i,j,1 )) 13 r(i,j,l)=r(i,j,l)+dzi*(w(i,j,l)*d(i,j,l)-w(i,j,l-1)*d(i,j,l-1)) else do 113 j=1,mp do 113 i=1,np r(i,j,1)=r(i,j,1)+dzil*(w(i,j,2)*d(i,j,2)-w(i,j,l-1)*d(i,j,l-1)) r(i,j,l)=r(i,j,l)+dzil*(w(i,j,2)*d(i,j,2)-w(i,j,l-1)*d(i,j,l-1)) 113 continue endif if(iflg.ne.0) then do 4 k=1,l do 4 j=1,mp do 4 i=1,np 4 r(i,j,k)=iflg*r(i,j,k)/d(i,j,k) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif if(iflg.eq.0) then if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 5 k=2,l do 5 j=jllim,mp do 5 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j ,k )*d(i,j ,k )-u(i-1,j ,k )*d(i-1,j ,k ) 1 +u(i,j-j3,k )*d(i,j-j3,k )-u(i-1,j-j3,k )*d(i-1,j-j3,k ) 1 +u(i,j ,k-1)*d(i,j ,k-1)-u(i-1,j ,k-1)*d(i-1,j ,k-1) 1 +u(i,j-j3,k-1)*d(i,j-j3,k-1)-u(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i ,j ,k )*d(i ,j ,k )-v(i ,j-j3,k )*d(i ,j-j3,k ) 2 +v(i-1,j ,k )*d(i-1,j ,k )-v(i-1,j-j3,k )*d(i-1,j-j3,k ) 2 +v(i ,j ,k-1)*d(i ,j ,k-1)-v(i ,j-j3,k-1)*d(i ,j-j3,k-1) 2 +v(i-1,j ,k-1)*d(i-1,j ,k-1)-v(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i ,j ,k)*d(i ,j ,k)-w(i ,j ,k-1)*d(i ,j ,k-1) 3 +w(i-1,j ,k)*d(i-1,j ,k)-w(i-1,j ,k-1)*d(i-1,j ,k-1) 3 +w(i ,j-j3,k)*d(i ,j-j3,k)-w(i ,j-j3,k-1)*d(i ,j-j3,k-1) 3 +w(i-1,j-j3,k)*d(i-1,j-j3,k)-w(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=2,l do 51 i=illim,np r(i,1,k)=dxi2* 1 dxi2*( u(i,1 ,k )*d(i ,1,k )-u(i-1,1,k )*d(i-1,1,k ) 1 +u(i,1 ,k-1)*d(i ,1,k-1)-u(i-1,1,k-1)*d(i-1,1,k-1)) 3 +dzi2*( w(i ,1,k )*d(i ,1,k )-w(i ,1,k-1)*d(i ,1,k-1) 3 +w(i-1,1,k )*d(i-1,1,k )-w(i-1,1,k-1)*d(i-1,1,k-1)) 51 continue endif else if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 6 k=2,l do 6 j=jllim,mp do 6 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j ,k )*d(i,j ,k )-u(i-1,j ,k )*d(i-1,j ,k ) 1 +u(i,j-j3,k )*d(i,j-j3,k )-u(i-1,j-j3,k )*d(i-1,j-j3,k ) 1 +u(i,j ,k-1)*d(i,j ,k-1)-u(i-1,j ,k-1)*d(i-1,j ,k-1) 1 +u(i,j-j3,k-1)*d(i,j-j3,k-1)-u(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i ,j ,k )*d(i ,j ,k )-v(i ,j-j3,k )*d(i ,j-j3,k ) 2 +v(i-1,j ,k )*d(i-1,j ,k )-v(i-1,j-j3,k )*d(i-1,j-j3,k ) 2 +v(i ,j ,k-1)*d(i ,j ,k-1)-v(i ,j-j3,k-1)*d(i ,j-j3,k-1) 2 +v(i-1,j ,k-1)*d(i-1,j ,k-1)-v(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i ,j ,k)*d(i ,j ,k)-w(i ,j ,k-1)*d(i ,j ,k-1) 3 +w(i-1,j ,k)*d(i-1,j ,k)-w(i-1,j ,k-1)*d(i-1,j ,k-1) 3 +w(i ,j-j3,k)*d(i ,j-j3,k)-w(i ,j-j3,k-1)*d(i ,j-j3,k-1) 3 +w(i-1,j-j3,k)*d(i-1,j-j3,k)-w(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) rhoav=.125*( d(i ,j ,k )+d(i-1,j ,k ) 1 +d(i-1,j-j3,k )+d(i ,j-j3,k ) 1 +d(i ,j ,k-1)+d(i-1,j ,k-1) 1 +d(i-1,j-j3,k-1)+d(i ,j-j3,k-1) ) 6 r(i,j,k)=iflg*r(i,j,k)/rhoav else dxi2=2.*dxil dzi2=2.*dzil do 61 k=2,l do 61 i=illim,np r(i,1,k)= 1 dxi2*( u(i ,1,k )*d(i ,1,k )-u(i-1,1,k )*d(i-1,1,k ) 1 +u(i ,1,k-1)*d(i ,1,k-1)-u(i-1,1,k-1)*d(i-1,1,k-1)) 3 +dzi2*( w(i ,1,k )*d(i ,1,k )-w(i ,1,k-1)*d(i ,1,k-1) 3 +w(i-1,1,k )*d(i-1,1,k )-w(i-1,1,k-1)*d(i-1,1,k-1)) rhoav=.25*(d(i,1,k)+d(i-1,1,k)+d(i,1,k-1)+d(i-1,1,k-1)) 61 r(i,1,k)=iflg*r(i,1,k)/rhoav endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif call update(r,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(12) #endif return end #if (ANALIZE == 0) #if (MHD == 1) subroutine rBB(bx,by,bz,ox,oy,oz,rho,fx,fy,fz,xmiui) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 c do k=1,l c do j=1,mp c do i=1,np c bx(i,j,k)=bx(i,j,k)*sqrt(xmiui/rho(i,j,k)) c by(i,j,k)=by(i,j,k)*sqrt(xmiui/rho(i,j,k)) c bz(i,j,k)=bz(i,j,k)*sqrt(xmiui/rho(i,j,k)) c enddo c enddo c enddo do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do call bvprd(bx,by,bz,ox,oy,oz) call donorc(x0,y0,z0,bx,rh0,31,fx) call donorc(x0,y0,z0,by,rh0,32,fy) call donorc(x0,y0,z0,bz,rh0,33,fz) c call mpdatm3B(x0,y0,z0,bx,rh0,31,fx) c call mpdatm3B(x0,y0,z0,by,rh0,32,fy) c call mpdatm3B(x0,y0,z0,bz,rh0,33,fz) do k=1,l do j=1,mp do i=1,np fx(i,j,k)=xmiui*fx(i,j,k)*rh0(i,j,k)/rho(i,j,k) fy(i,j,k)=xmiui*fy(i,j,k)*rh0(i,j,k)/rho(i,j,k) fz(i,j,k)=xmiui*fz(i,j,k)*rh0(i,j,k)/rho(i,j,k) c fx(i,j,k)=fx(i,j,k)/dt c fy(i,j,k)=fy(i,j,k)/dt c fz(i,j,k)=fz(i,j,k)/dt c bx(i,j,k)=bx(i,j,k)*sqrt(rho(i,j,k)/xmiui) c by(i,j,k)=by(i,j,k)*sqrt(rho(i,j,k)/xmiui) c bz(i,j,k)=bz(i,j,k)*sqrt(rho(i,j,k)/xmiui) enddo enddo enddo return end subroutine rBVeO(bx,by,bz,ux,uy,uz,fx,fy,fz) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ux(1-ih:np+ih, 1-ih:mp+ih, l), . uy(1-ih:np+ih, 1-ih:mp+ih, l), . uz(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) call grad(ux,phix,phiy,phiz,1) c call grad(ux,phix,phiy,phiz,0) do k=1,l do j=1,mp do i=1,np fx(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=phix(i,j,k) enddo enddo enddo call grad(uy,phix,phiy,phiz,1) do k=1,l do j=1,mp do i=1,np fy(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=div(i,j,k)+phiy(i,j,k) enddo enddo enddo call grad(uz,phix,phiy,phiz,0) do k=1,l do j=1,mp do i=1,np fz(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=div(i,j,k)+phiz(i,j,k) enddo enddo enddo c call filstr(fx) c call filstr(fy) c call filstr(fz) compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar idiv=0 if(idiv.eq.1) then dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(uz(i,j,k+1)+2.*uz(i,j,k)+uz(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(uz(i,j,2)+2.*uz(i,j,1)+uz(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *uz(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *uz(i,j,L)/rho(i,j,L) endif end do end do endif do k=1,l do j=1,mp do i=1,np fx(i,j,k)= fx(i,j,k)-bx(i,j,k)*div(i,j,k) fy(i,j,k)= fy(i,j,k)-by(i,j,k)*div(i,j,k) fz(i,j,k)= fz(i,j,k)-bz(i,j,k)*div(i,j,k) enddo enddo enddo return end subroutine rBVeN(bx,by,bz,ox,oy,oz,u,v,w,fx,fy,fz,iflg) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih, 1-ih:mp+ih,l), . v(1-ih:np+ih, 1-ih:mp+ih,l), . w(1-ih:np+ih, 1-ih:mp+ih,l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) c common/mhdscr/ div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do if(iflg.eq.1) & call bvprd(bx,by,bz,ox,oy,oz) call donorc(x0,y0,z0,u,rh0,2,fx) call donorc(x0,y0,z0,v,rh0,3,fy) call donorc(x0,y0,z0,w,rh0,4,fz) compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(w(i,j,k+1)+2.*w(i,j,k)+w(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(w(i,j,2)+2.*w(i,j,1)+w(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *w(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *w(i,j,L)/rho(i,j,L) endif end do end do do k=1,l do j=1,mp do i=1,np fx(i,j,k)= fx(i,j,k)-bx(i,j,k)*div(i,j,k) fy(i,j,k)= fy(i,j,k)-by(i,j,k)*div(i,j,k) fz(i,j,k)= fz(i,j,k)-bz(i,j,k)*div(i,j,k) enddo enddo enddo return end subroutine rBVi(bx,by,bz,ux,uy,uz) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ux(1-ih:np+ih, 1-ih:mp+ih, l), . uy(1-ih:np+ih, 1-ih:mp+ih, l), . uz(1-ih:np+ih, 1-ih:mp+ih, l) c common/mhdscr/ div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,3), ! free . c11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c11 . c12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c12 . c13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c13 . c21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c21 . c22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c22 . c23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c23 . c31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c31 . c32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c32 . c33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c33 . temp(1-ih:np+ih,1-ih:mp+ih,l, 4) ! not used det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 idiv=0 do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do call grad(ux,c11,c12,c13,1) c call grad(ux,c11,c12,c13,0) call grad(uy,c21,c22,c23,1) call grad(uz,c31,c32,c33,0) if(idiv.eq.0) then do k=1,l do j=1,mp do i=1,np div(i,j,k)=c11(i,j,k)+c22(i,j,k)+c33(i,j,k) enddo enddo enddo else compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(uz(i,j,k+1)+2.*uz(i,j,k)+uz(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(uz(i,j,2)+2.*uz(i,j,1)+uz(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *uz(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *uz(i,j,L)/rho(i,j,L) endif end do end do endif dthng=-dt*0.5 eps=1.e-10 do k=1,l do j=1,mp do i=1,np a11 = 1.+dthng*(c11(i,j,k)-div(i,j,k)) a12 = dthng* c12(i,j,k) a13 = dthng* c13(i,j,k) a21 = dthng* c21(i,j,k) a22 = 1.+dthng*(c22(i,j,k)-div(i,j,k)) a23 = dthng* c23(i,j,k) a31 = dthng* c31(i,j,k) c a31 = dthng* c21(i,j,k) a32 = dthng* c32(i,j,k) a33 = 1.+dthng*(c33(i,j,k)-div(i,j,k)) b1=bx(i,j,k) b2=by(i,j,k) b3=bz(i,j,k) det =det3(a11,a12,a13,a21,a22,a23,a31,a32,a33) deti=sign(1.,det)/amax1(abs(det),eps) detx=det3( b1,a12,a13, b2,a22,a23, b3,a32,a33) dety=det3(a11, b1,a13,a21, b2,a23,a31, b3,a33) detz=det3(a11,a12, b1,a21,a22, b2,a31,a32, b3) bx(i,j,k)=detx*deti by(i,j,k)=dety*deti bz(i,j,k)=detz*deti enddo enddo enddo do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do return end subroutine grad(p,pfx,pfy,pfz,iflip) include 'param.nml' include 'msg.inc' dimension p(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/blank/ scr12(1-ih:np+ih,1-ih:mp+ih,l,12), ! gcrk, coef0 . scr13(1-ih:np+ih,1-ih:mp+ih,l), ! free array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:nmhdp+ih+1, 1-ih:mmhdp+ih+1, lmhd+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigidB/ bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) coefficients e1,e2,e3 define extrapolation scheme in pressure boundary conditions for tangential contributions to pressure forces for B-grid calculations common/indx/ e1,e2,e3 call update(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np if (iflip.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge else jllim = 1 julim = mp endif #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do 18 k=1,l do 18 j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) 18 continue end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do 28 k=1,l do 28 i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) 28 continue end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #else c modif POLES if (iflip.eq.1) then if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=dyil*(p(i,1+j3,k)+p(i,1,k)) c py(i,1,k)=dyil*(p(i,1+j3,k)+p(i,0,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=-dyil*(p(i,mp,k)+p(i,mp-j3,k)) c py(i,mp,k)=-dyil*(p(i,mp+1,k)+p(i,mp-j3,k)) end do end do end if end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do 38 j=1,mp do 38 i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) 38 pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) else do 381 j=1,mp do 381 i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) 381 pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + 1*rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if(PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if(PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,iup) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,iup) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces do 10 k=1,l do 10 j=1,mp do 10 i=1,np g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) pfx(i,j,k)=g11*px(i,j,k)+g12*py(i,j,k)+g13*pz(i,j,k) pfy(i,j,k)=g21*px(i,j,k)+g22*py(i,j,k)+g23*pz(i,j,k) 10 pfz(i,j,k)=g33*pz(i,j,k) return end subroutine donorc(u1,u2,u3,x,h,iflg,flxdv) include 'param.nml' include 'msg.inc' dimension u1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . u2(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . u3(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . x(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . h(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . flxdv(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c c pp(y)= amax1(0.,y) c pn(y)=-amin1(0.,y) c donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 donor(y1,y2,a)=a*(y1+y2)*0.5 c call update(x,np,mp,l,np,mp,iup) iboz=1-ibcz #if (POLES == 0) /* !modpol */ ibox=1-ibcx iboy=1-ibcy ibcxy=ibcx*ibcy #else ibox=0 iboy=0 ibcxy=1 #endif do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c illim = 1 + leftedge do k=1,n3m do j=1,mp do i=illim,iulim c do i=illim,np !modpol v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + 1*botedge julim = mp do k=1,n3m do j=jllim,julim !modpol c do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if c if((itr.eq.1).and.(ibcxy.eq.0)) !mod check if(ibcxy.eq.0) . call mp3bc_mhd(x,iflg,bcx,bcy,np,mp,n3m) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c ilft=1+leftedge*1 do k=1,n3m do j=1,mp do i=illim,iulim !modpol c do i=ilft,np f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)= . donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= . donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp !modpol c jbot=1+botedge*1 do k=1,n3m do j=jllim,julim c do j=jbot,mp do i=1,np f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)= . donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) do j=1,mp do i=1,np c if (iflg.ge.31.and.iflg.le.33) then c f3(i,j, 1)= f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c endif c if (iflg.eq.2.or.iflg.eq.3.or.(iflg.ge.31.and.iflg.le.33)) then c f3(i,j,n3)= f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz !mod bbc c else f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz c endif enddo enddo do k=1,n3m do j=1,mp do i=1,np flxdv(i,j,k)= ( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k)*dti end do end do end do c call update(flxdv,np,mp,l,np,mp,iup) return end subroutine mp3bc_mhd(x,iflg,bcx,bcy,n1,n2,n3) include 'param.nml' include 'msg.inc' common/profB/ prfb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) dimension x(1-ih:np+ih,1-ih:mp+ih,l), . bcx(1-ih:mp+ih,n3,2), . bcy(1-ih:np+ih,n3,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/znave/ uza(mp,l,3),thza(mp,l),qvza(mmsp,lms), . bza(mmhdp,lmhd,3) #if (TIMEPLT == 1) call ttbeg(36) #endif #if (POLES == 0) /* !modpol */ if(iflg.eq.1) then ! ---> th if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(1,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(mp,k) enddo enddo end if else if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if endif goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb( 1,j,k,iflg-30) bcx(j,k,2)=prfb( 0,j,k,iflg-30) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb(np+1,j,k,iflg-30) bcx(j,k,2)=prfb(np,j,k,iflg-30) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i, 1,k,iflg-30) bcy(i,k,2)=prfb(i, 0,k,iflg-30) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i,mp+1,k,iflg-30) bcy(i,k,2)=prfb(i,mp,k,iflg-30) enddo enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.11) then ! ---> thf if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if goto 999 endif #endif if(iflg.eq.2.or.iflg.eq.3) then ! ---> u0.v0 if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,iflg) bcx(j,k,2)=prf( 0,j,k,iflg) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,iflg) bcx(j,k,2)=prf(np,j,k,iflg) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,iflg) C +uza(1,k,iflg-1) bcy(i,k,2)=prf(i, 0,k,iflg) C +uza(0,k,iflg-1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,iflg) C +uza(mp+1,k,iflg-1) bcy(i,k,2)=prf(i,mp,k,iflg) C +uza(mp,k,iflg-1) enddo enddo end if goto 999 endif if(iflg.eq.51) then ! ---> fox if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bcx(j,k,1)=g11w*prf(1,j,k,2)+g21w*prf(1,j,k,3)+strxd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bcx(j,k,2)=g11w*prf(0,j,k,2)+g21w*prf(0,j,k,3)+strxd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bcx(j,k,1)=g11e*prf(np+1,j,k,2)+g21e*prf(np+1,j,k,3)+strxd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bcx(j,k,2)=g11e*prf(np,j,k,2)+g21e*prf(np,j,k,3)+strxd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g11s=strxx(i,1)*g110s g21s=strxy(i,1)*g220s c bcy(i,k,1)=g11w*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) bcy(i,k,1)=g11s*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) !mod Andii g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g11s=strxx(i,0)*g110s g21s=strxy(i,0)*g220s c bcy(i,k,2)=g11w*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) bcy(i,k,2)=g11s*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) !mod Andii enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g11n=strxx(i,mp+1)*g110n g21n=strxy(i,mp+1)*g220n bcy(i,k,1)=g11n*prf(i,mp+1,k,2)+g21n*prf(i,mp+1,k,3)+strxd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g11n=strxx(i,mp)*g110n g21n=strxy(i,mp)*g220n bcy(i,k,2)=g11n*prf(i,mp,k,2)+g21n*prf(i,mp,k,3)+strxd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.52) then ! ---> foy if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g12w=stryx(1,j)*g110w g22w=stryy(1,j)*g220w bcx(j,k,1)=g12w*prf(1,j,k,2)+g22w*prf(1,j,k,3)+stryd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g12w=stryx(0,j)*g110w g22w=stryy(0,j)*g220w bcx(j,k,2)=g12w*prf(0,j,k,2)+g22w*prf(0,j,k,3)+stryd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g12e=stryx(np+1,j)*g110e g22e=stryy(np+1,j)*g220e bcx(j,k,1)=g12e*prf(np+1,j,k,2)+g22e*prf(np+1,j,k,3)+stryd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g12e=stryx(np,j)*g110e g22e=stryy(np,j)*g220e bcx(j,k,2)=g12e*prf(np,j,k,2)+g22e*prf(np,j,k,3)+stryd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bcy(i,k,1)=g12s*prf(i,1,k,2)+g22s*prf(i,1,k,3)+stryd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bcy(i,k,2)=g12s*prf(i,0,k,2)+g22s*prf(i,0,k,3)+stryd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bcy(i,k,1)=g12n*prf(i,mp+1,k,2)+g22n*prf(i,mp+1,k,3)+stryd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bcy(i,k,2)=g12n*prf(i,mp,k,2)+g22n*prf(i,mp,k,3)+stryd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then ! w0| foz |ftf,fqv,fqc,fqr if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(1,k,3) bcy(i,k,2)=0. C +uza(0,k,3) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(mp+1,k,3) bcy(i,k,2)=0. C +uza(mp,k,3) enddo enddo end if goto 999 endif #if (MOISTMOD > 0) if(iflg.eq.6) then ! ---> qv if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve( 1,j,k) bcx(j,k,2)=qve( 0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(np+1,j,k) bcx(j,k,2)=qve(np,j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i, 1,k) bcy(i,k,2)=qve(i, 0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i,mp+1,k) bcy(i,k,2)=qve(i,mp,k) enddo enddo end if goto 999 endif if(iflg.ge.7) then ! ---> qc if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo end if goto 999 endif #endif #endif 999 continue #if (TIMEPLT == 1) call ttend(36) #endif return end #endif /* MHD == 1 */ subroutine integz(a,b) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l), . b(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(65) #endif do k=2,l-1 do j=1,mp do i=1,np b(i,j,k)=0.25*(a(i,j,k+1)+2.*a(i,j,k)+a(i,j,k-1)) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np b(i,j,1)=0.5*(a(i,j,2)+a(i,j, 1)) b(i,j,l)=0.5*(a(i,j,l)+a(i,j,l-1)) enddo enddo else do j=1,mp do i=1,np b(i,j,1)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) b(i,j,l)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) enddo enddo endif do k=1,l do j=1,mp do i=1,np a(i,j,k)=b(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(65) #endif return end subroutine prforc(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob,ibf) include 'param.nml' include 'msg.inc' compute available storage in // parameter (nml=n*m*l) c parameter (nml=n*m*l,iuse=12) c common// wara(iuse) dimension wgx(np),wgy(mp),wgz(l) dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), . fc(1-ih:np+ih, 1-ih:mp+ih, l), . fd(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . pfx(1-ih:np+ih, 1-ih:mp+ih, l), . pfy(1-ih:np+ih, 1-ih:mp+ih, l), . pfz(1-ih:np+ih, 1-ih:mp+ih, l) dimension ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) dimension tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/blank/ scr12(1-ih:np+ih,1-ih:mp+ih,l,12), ! gcrk, coef0 . scr13(1-ih:np+ih,1-ih:mp+ih,l), ! free array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) c common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), !mod c . ub(1-ih:mp+ih, l , 2), c . vb(1-ih:np+ih, l , 2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip !mod bbc common/slipb/ noslipb coefficients e1,e2,e3 define extrapolation scheme in pressure boundary conditions for tangential contributions to pressure forces for B-grid calculations common/indx/ e1,e2,e3 c pp(xx)=amax1(xx,0.) c pn(xx)=amin1(xx,0.) #if (TIMEPLT == 1) call ttbeg(13) #endif compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 call update(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do 18 k=1,l do 18 j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) 18 continue end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do 28 k=1,l do 28 i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) 28 continue end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do 38 j=1,mp do 38 i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) 38 pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) else do 381 j=1,mp do 381 i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) 381 pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) /* Not ready for POLES = 1 */ dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if(PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if(PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,1) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif #else STOP 'B GRID NOT READY FOR CYCLIC POLE CONDITIONS' #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces c---> c = astri c---> fc = Gmod c---> fd = 1./etainv do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pz(i,j,k)) pfy(i,j,k)=v(i,j,k)-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pz(i,j,k)) 10 pfz(i,j,k)=w(i,j,k)-(c31*px(i,j,k)+c32*py(i,j,k)+c33*pz(i,j,k)) compute pressure forces at the boundaries #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge do 11 i=illim,iulim,np-1 ii=1+i/np do 111 j=jllim,julim ja=(mpos-1)*mp + j do 111 k=2-ibcz,l-1+ibcz F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfx(i,j,k)= ub(j,k,ii)*coefi pxb=( u(i,j,k)-pfx(i,j,k)-(c12*py(i,j,k)+c13*pz(i,j,k)) )/c11 pfy(i,j,k)=v(i,j,k)-(c21*pxb+c22*py(i,j,k)+c23*pz(i,j,k)) 111 pfz(i,j,k)= . icw*(w(i,j,k)-(c31*pxb+c32*py(i,j,k)+c33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 11 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 112 i=illim,iulim,np-1 ii=1+i/np do 112 j=jllim,julim,mp-j3 jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfx(i,j,k)= ub(j,k,ii)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi a=u(i,j,k)-pfx(i,j,k)-c13*pz(i,j,k) b=v(i,j,k)-pfy(i,j,k)-c23*pz(i,j,k) pxb=(c22*a-c12*b)/(c11*c22-c12*c21) pyb=(c11*b-c21*a)/(c11*c22-c12*c21) 1121 pfz(i,j,k)=w(i,j,k)-(c31*pxb+c32*pyb+c33*pz(i,j,k)) 112 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge do 12 j=jllim,julim,mp-j3 jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfy(i,j,k)= vb(i,k,jj)*coefi pyb=( v(i,j,k)-pfy(i,j,k)-(c21*px(i,j,k)+c23*pz(i,j,k)) )/c22 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*pyb+c13*pz(i,j,k)) 121 pfz(i,j,k)= . icw*(w(i,j,k)-(c31*px(i,j,k)+c32*pyb+c33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 12 continue endif #endif if(ibcz.eq.0) then #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge #else jllim = 1 julim = mp illim = 1 iulim = np #endif do 20 k=1,l,l-1 kk=1+k/l do 21 j=jllim,julim do 21 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pzb=(w(i,j,k)-pfz(i,j,k)-(c31*px(i,j,k)+c32*py(i,j,k)))/c33 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pzb) pfy(i,j,k)=v(i,j,k)-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pzb) 21 continue 20 continue #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if do 211 k=1,l,l-1 kk=1+k/l do 211 i=illim,iulim,np-1 ii=1+i/np do 2111 j=jllim,julim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi pzb=(c11*(w(i,j,k)-pfz(i,j,k))-c31*(u(i,j,k)-pfx(i,j,k)) . -(c11*c32-c31*c12)*py(i,j,k) )/(c11*c33-c31*c13) pxb=(u(i,j,k)-pfx(i,j,k)-(c12*py(i,j,k)+c13*pzb))/c11 2111 pfy(i,j,k)=v(i,j,k)-(c21*pxb+c22*py(i,j,k)+c23*pzb) 211 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 212 k=1,l,l-1 kk=1+k/l do 212 i=illim,iulim,np-1 ii=1+i/np do 212 j=jllim,julim,mp-j3 jj=1+j/mp coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi 212 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if cdel a11=1. do 221 k=1,l,l-1 kk=1+k/l do 221 j=jllim,julim,mp-j3 jj=1+j/mp do 221 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi pzb=( c22*(w(i,j,k)-pfz(i,j,k))-c32*(v(i,j,k)-pfy(i,j,k)) . -(c31*c22-c32*c21)*px(i,j,k) )/(c33*c22-c32*c23) pyb=(v(i,j,k)-pfy(i,j,k)-(c21*px(i,j,k)+c23*pzb))/c22 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*pyb+c13*pzb) 221 continue 999 continue endif ! ibcy.eq.0.and.j3.eq.1 #endif endif ! ibcz.eq.0 do 99 k=1,l do 99 j=1,mp do 99 i=1,np pfx(i,j,k)=fd(i,j,k)*pfx(i,j,k) pfy(i,j,k)=fd(i,j,k)*pfy(i,j,k) 99 pfz(i,j,k)=fd(i,j,k)*pfz(i,j,k) if(noslip.eq.1) then customized for QBO lab experiment, noslip x boundaries, and zbar=0 as an option #if (POLES == 0) if(leftedge.eq.1) then do k=1,l do j=1,mp c pfx(1,j,k)=0. pfy(1,j,k)=0. pfz(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c pfx(np,j,k)=0. pfy(np,j,k)=0. pfz(np,j,k)=0. enddo enddo endif #endif c---> noslip lower boundary do j=1,mp do i=1,np pfx(i,j,1)=0. pfy(i,j,1)=0. c pfx(i,j,l)=0. c pfy(i,j,l)=0. enddo enddo endif !mod bbc ! if(ibf.eq.2.and.noslipb.eq.1) then if(ibf.eq.2) then c---> noslipb upper boundary if (ibbl .eq. 1) then do j=1,mp do i=1,np pfx(i,j,1) = 0. pfy(i,j,1) = 0. enddo enddo endif if (ibbu .eq. 1) then do j=1,mp do i=1,np pfx(i,j,l) = 0. pfy(i,j,l) = 0. enddo enddo endif ! if (noslipb.eq.1) then ! do j=1,mp ! do i=1,np ! pfx(i,j,1) = 0. ! pfy(i,j,1) = 0. ! pfx(i,j,l) = 0. ! pfy(i,j,l) = 0. ! enddo ! enddo ! endif ! if (noslipb.eq.2) then ! do j=1,mp ! do i=1,np ! pfx(i,j,l) = 0. ! pfy(i,j,l) = 0. ! enddo ! enddo ! endif ! if (noslipb .ge. 1) call bbcad(ub,vb,ob,rh0) if ((ibbl .eq. 1).or.(ibbu.eq.1)) call bbcad(ub,vb,ob,rh0) endif if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if(iencyc.eq.1) then c enforce cyclicity !mod if(ibcx.eq.1) then call updatelr(pfx,np,mp,l,np,mp,1) call updatelr(pfy,np,mp,l,np,mp,1) call updatelr(pfz,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp pfx(np,j,k)=pfx(np+1,j,k) pfy(np,j,k)=pfy(np+1,j,k) pfz(np,j,k)=pfz(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(pfx,np,mp,l,np,mp,1) call updatebt(pfy,np,mp,l,np,mp,1) call updatebt(pfz,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np pfx(i,mp,k)=pfx(i,mp+j3,k) pfy(i,mp,k)=pfy(i,mp+j3,k) pfz(i,mp,k)=pfz(i,mp+j3,k) enddo enddo endif endif endif !iencyc #if (TIMEPLT == 1) call ttend(13) #endif return end subroutine gcrk(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob, . itr,eps0,inner,ibf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . pfx(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . pfy(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . pfz(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fx . fc(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fy . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . ft(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: ft dimension ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/blank/ r(1-ih:np+ih,1-ih:mp+ih,l), ! --> r . qr(1-ih:np+ih,1-ih:mp+ih,l), ! --> qr . ar(1-ih:np+ih,1-ih:mp+ih,l), ! --> ar . scr3(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c11 . scr4(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c12 . scr5(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c13 . scr6(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c21 . scr7(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c22 . scr8(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c23 . scr9(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c31 . scr11(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c32 . scr12(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c33 . tmp1(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp2(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp3(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp4(1-ih:np+ih,1-ih:mp+ih,l) ! local array parameter (lrd=3) c parameter (lrd=9) dimension ax2(lrd),axar(lrd),del(lrd) dimension x(1-ih:np+ih, 1-ih:mp+ih, l, lrd), . ax(1-ih:np+ih, 1-ih:mp+ih, l, lrd) real globmax,globsum convergence test modes ************************************************** logical ctest * data ctest/.false./ * c data ctest/.true./ * parameter (nplt=100) * dimension err(0:nplt),xitr(0:nplt) * #if (TIMEPLT == 1) call ttbeg(10) #endif if(ctest) then * itr=900/lrd * ner=2 * snorm=1./float(n*m*l) * eps0=1.e-15 * endif * convergence test modes ************************************************** c itr=90/lrd #if (POLES == 0) kl = 1 + igrid jl = 1 + igrid*j3*botedge il = 1 + igrid*leftedge #else kl = 1 jl = 1 il = 1 #endif lord=lrd if(inner.ge.1) lord=3 eps=eps0*dti if(ibf.eq.2) eps=1.e-2*eps ! eps~sqrt(100.*xmiu)*eps nml=n*m*l epa=1.e-30 nlc=0 c ------ number of outer cycles of pressure iterations: c e.g., calls to precon/lapc: see 200 loop below itmn=1 iprc=1 if(igrid.eq.1) iprc=0 ! grid B call coef0(c,fc,fd,ft) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,0) do k1=1,l do j1=1,mp do i1=1,np r(i1,j1,k1)=0. ar(i1,j1,k1)=0. qr(i1,j1,k1)=0. enddo end do end do do i=1,lord do k1=1,l do j1=1,mp do i1=1,np x(i1,j1,k1,i)=0. ax(i1,j1,k1,i)=0. enddo end do end do enddo call prforc(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob,ibf) call rhsdiv(pfx,pfy,pfz,rho,r,-1) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,1) eer0=0. eem0=-1.e15 rl20=0. dvmx0=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) tmp3(i1,j1,k1)=r(i1,j1,k1)**2 tmp4(i1,j1,k1)=abs(r(i1,j1,k1)) enddo end do end do eer0=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) eem0=globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) rl20=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx=globmax(tmp4,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx= amax1(dvmx,dvmx0) eer0=amax1(eer0,epa) eem0=amax1(eem0,epa) rl20=amax1(rl20,epa) if((dvmx.le.eps).and.(ispcpr.eq.1)) then do k1=kl,l do j1=jl,mp do i1=il,np p(i1,j1,k1)= p(i1,j1,k1)-qr(i1,j1,k1) end do end do end do go to 200 endif convergence test modes ************************************************** if(ctest) then * do ier=0,nplt * err(ier)=eps * enddo * eer=-1.e15 * do k1=kl,l * do j1=jl,mp * do i1=il,np * tmp1(i1,j1,k1)=abs(r(i1,j1,k1)) * enddo * end do * end do * eer=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) * err(0)=eer * if (mype.eq.0) print 300, err(0) * 300 format(4x,e11.4,' residual error at it=1') * endif * convergence test modes ************************************************** do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1)=qr(i1,j1,k1) enddo end do end do call laplc(x(1-ih,1-ih,1,1),ax(1-ih,1-ih,1,1),pfx,pfy,pfz,fd,ibf) c ***** inner iterations ***** do 100 it=1,itr do i=1,lord dvmx0=-1.e15 rl2=0. rax=0. ax2(i)=0. do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)= r(i1,j1,k1)* ax(i1,j1,k1,i) tmp2(i1,j1,k1)= ax(i1,j1,k1,i)* ax(i1,j1,k1,i) end do end do end do rax=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) ax2(i)=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) ax2(i)=amax1(epa,ax2(i)) beta=-rax/ax2(i) do k1=kl,l do j1=jl,mp do i1=il,np p(i1,j1,k1)= p(i1,j1,k1)+beta* x(i1,j1,k1,i) r(i1,j1,k1)= r(i1,j1,k1)+beta*ax(i1,j1,k1,i) tmp3(i1,j1,k1)=abs(r(i1,j1,k1)) tmp4(i1,j1,k1)= r(i1,j1,k1)* r(i1,j1,k1) end do end do end do dvmx=globmax(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx= amax1(dvmx,dvmx0) rl2 =globsum(tmp4,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) if((dvmx.le.eps).and.(it.gt.itmn)) go to 200 ! Linf norm if((rl2.ge.rl20).and.(.not.ctest)) go to 200 ! L2 norm rl20=amax1(rl2,epa) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,1) call laplc(qr,ar,pfx,pfy,pfz,fd,ibf) nlc=nlc+1 do ii=1,i axar(ii)=0. do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=ax(i1,j1,k1,ii)*ar(i1,j1,k1) end do end do end do axar(ii)=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) del(ii)=-axar(ii)/ax2(ii) c del(ii)=amax1(del(ii),0.5) enddo if(i.lt.lord) then do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,i+1)=qr(i1,j1,k1) ax(i1,j1,k1,i+1)=ar(i1,j1,k1) enddo end do end do do ii=1,i do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,i+1)= x(i1,j1,k1,i+1)+del(ii)* x(i1,j1,k1,ii) ax(i1,j1,k1,i+1)=ax(i1,j1,k1,i+1)+del(ii)*ax(i1,j1,k1,ii) enddo end do end do enddo else do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1)=qr(i1,j1,k1)+del(1)* x(i1,j1,k1,1) ax(i1,j1,k1,1)=ar(i1,j1,k1)+del(1)*ax(i1,j1,k1,1) enddo end do end do do ii=2,i do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1 )= x(i1,j1,k1,1)+del(ii)* x(i1,j1,k1,ii) x(i1,j1,k1,ii)=0. ax(i1,j1,k1,1 )=ax(i1,j1,k1,1)+del(ii)*ax(i1,j1,k1,ii) ax(i1,j1,k1,ii)=0. enddo end do end do enddo endif convergence test modes ************************************************** if(ctest) then * if(nlc/ner*ner.eq.nlc) then * ier=nlc/ner * eer=-1.e15 * do k1=kl,l * do j1=jl,mp * do i1=il,np * tmp1(i1,j1,k1)=abs(r(i1,j1,k1)) * enddo * end do * end do * eer=amax1(eer, * . globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) * err(ier)=eer * endif * endif * convergence test modes ************************************************** enddo 100 continue c ***** end inner iterations ***** 200 continue IF(ibf.eq.1) THEN eer=0. eem=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) enddo end do end do eer = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) eem = amax1(eem, . globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) eer=eer/eer0 eem=eem/eem0 if(inner.eq.0) then niter=nlc nitsm=nitsm+niter icount=icount+1 else miter=nlc mitsm=mitsm+miter jcount=jcount+1 endif ELSE erb=0. emb=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) enddo end do end do erb = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) emb = amax1(emb, . globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) erb=erb/eer0 emb=emb/eem0 if(inner.eq.0) then niteb=nlc nitsb=nitsb+niteb icounb=icounb+1 else miteb=nlc mitsb=mitsb+miteb jcounb=jcounb+1 endif ENDIF !(ibf.eq.1) if(inner.eq.0) then niter=nlc nitsm=nitsm+niter icount=icount+1 c if (mype.eq.0) print 205, inner,niter,dvmx,eer,eem 205 format(1x,'inner,niter,dvmx,eer,eem:',i2,i6,3e11.4) else miter=nlc mitsm=mitsm+miter jcount=jcount+1 c if (mype.eq.0) print 206, inner,miter,dvmx,eer,eem 206 format(1x,'inner,miter,dvmx,eer,eem:',i2,i6,3e11.4) endif convergence test modes ************************************************** if(ctest) then * if (mype.eq.0) print 301, (err(ier),ier=1,nplt,1) * 301 format(4x,5e11.4) * endif * convergence test modes ************************************************** #if (TIMEPLT == 1) call ttend(10) #endif return end subroutine coef0(c,fc,fd,ft) include 'param.nml' include 'msg.inc' dimension c(1-ih:np+ih, 1-ih:mp+ih, l), . fc(1-ih:np+ih, 1-ih:mp+ih, l), . fd(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) c scr0 to scr2 are occupied by r,qr,ar; common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar . c11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c11 . c12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c12 . c13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c13 . c21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c21 . c22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c22 . c23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c23 . c31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c31 . c32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c32 . c33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c33 . temp(1-ih:np+ih,1-ih:mp+ih,l, 4) ! not used c---> c = astri c---> fc = Gmod c---> fd = 1./etainv #if (TIMEPLT == 1) call ttbeg(11) #endif do k=1,l do j=1,mp do i=1,np F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11(i,j,k)=g11*a11+g21*a21 c12(i,j,k)=g11*a12+g21*a22 c13(i,j,k)=g11*a13+g21*a23 c21(i,j,k)=g12*a11+g22*a21 c22(i,j,k)=g12*a12+g22*a22 c23(i,j,k)=g12*a13+g22*a23 c31(i,j,k)=g13*a11+g23*a21+g33*a31 c32(i,j,k)=g13*a12+g23*a22+g33*a32 c33(i,j,k)=g13*a13+g23*a23+g33*a33 end do end do end do #if (TIMEPLT == 1) call ttend(11) #endif return end subroutine precon(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: fz iprflg=ispcpr c iprflg=-1 #if(PRECF == 0) if(iprflg.eq.-1) call precon_df(rhs,p,r,c11,c22,c33,fd,iflg,jfl) if(iprflg.eq. 0) call precon_bcz(rhs,p,r,c11,c22,c33,fd,iflg,jfl) c if(iprflg.eq. 0) call precon_adi(rhs,p,r,c11,c22,c33,fd,iflg,jfl) #else if(iprflg.eq. 1) call precon_f(rhs,p,r,fd,iflg,jfl) #endif return end #if(PRECF == 0) subroutine precon_df(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . e(1-ih:np+ih, 1-ih:mp+ih, 0:l-1) ! local array dimension f(np,mp,0:l-1),dgh(np,mp,l) ! local arrays common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l), ! local array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array real globmax,globsum data beta/-1.e15/ c --- itr - number of richardson iterations c --- line - 0 = line iterations data itr,line/8,0/ c data itr,line/2,1/ c data itr,line/1,0/ #if (TIMEPLT == 1) call ttbeg(14) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(14) #endif return endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif omg=.7 oms=1.-omg dxi2=0.25*dxi*dxi dyi2=0.25*dyi*dyi dzi2=0.25*dzi*dzi do k=1,l do j=1,mp do i=1,np cf00=d(i,j,k)*fd(i,j,k) c11(i,j,k)=cf00*a11(i,j,k)*dxi2 c22(i,j,k)=cf00*a22(i,j,k)*dyi2 c33(i,j,k)=cf00*a33(i,j,k)*dzi2 dgh(i,j,k)=0. po(i,j,k)=0. p(i,j,k)=0. r(i,j,k)=0. enddo enddo enddo if(line.eq.1) then call updatelr(c11,np,mp,l,np,mp,iupx) call updatebt(c22,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim dgh(i,j,k)=c11(i+1,j,k)+c11(i-1,j,k) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dgh(1,j,k)=c11(2,j,k)+ibcx*c11(-1,j,k) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp dgh(np,j,k)=ibcx*c11(np+2,j,k)+c11(np-1,j,k) enddo enddo end if #endif if(j3.eq.1) then do k=1,l do j=jllim,julim do i=1,np dgh(i,j,k)=dgh(i,j,k)+c22(i,j+j3,k)+c22(i,j-j3,k) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dgh(i,1,k)=dgh(i,1,k)+c22(i,1+j3,k)+ibcy*c22(i,-j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dgh(i,mp,k)=dgh(i,mp,k)+ibcy*c22(i,mp+1+j3,k)+c22(i,mp-j3,k) enddo enddo end if #endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np do k=2,l-1 dgh(i,j,k)=dgh(i,j,k)+c33(i,j,k+1)+c33(i,j,k-1) enddo dgh(i,j,1)=dgh(i,j,1)+c33(i,j,l-1) dgh(i,j,l)=dgh(i,j,l)+c33(i,j, 2 ) enddo enddo endif endif if(jfl.eq.0) then if(line.eq.0) then beta=-1.e15 do k=1,l do j=1,mp do i=1,np e(i,j,k-1)=(abs(c11(i,j,k))+abs(c22(i,j,k)) . +ibcz*abs(c33(i,j,k)) )/d(i,j,k) enddo enddo enddo beta=amax1(globmax(e,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . beta) beta=0.5/beta else beta=1. endif #if (TIMEPLT == 1) call ttend(14) #endif return endif beti=1./beta*(1-line) do 100 it=1,itr do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+d(i,j,k)*(beti*p(i,j,k)-rhs(i,j,k)) . +dgh(i,j,k)*p(i,j,k) enddo enddo enddo IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np e(i,j,0)=1. f(i,j,0)=0. dn=d(i,j,1)*beti+2.*c33(i,j,2)+dgh(i,j,1) e(i,j,1)=2.*c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn enddo enddo do k=2,l-1 do j=1,mp do i=1,np dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn enddo enddo enddo do j=1,mp do i=1,np dn=d(i,j,l)*beti+2.*(1.-e(i,j,l-2))*c33(i,j,l-1) . + dgh(i,j,l) p(i,j,l)=(r(i,j,l)+2.*f(i,j,l-2)*c33(i,j,l-1))/dn p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) enddo enddo do k=l-2,1,-1 do j=1,mp do i=1,np p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE do k=1,l do j=1,mp do i=1,np dn=d(i,j,k)*beti+dgh(i,j,k) p(i,j,k)=r(i,j,k)/dn enddo enddo enddo ENDIF if(line.eq.1) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=oms*po(i,j,k)+omg*p(i,j,k) po(i,j,k)= p(i,j,k) enddo enddo enddo endif if(it.eq.itr) go to 101 call update2(p,np,mp,l,np,mp,iup) do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim px(i,j,k)=c11(i,j,k)*(p(i+1,j,k)-p(i-1,j,k)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=ibcx*c11(1,j,k)*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=ibcx*c11(np,j,k)*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 28 k=1,l do 28 j=jllim,julim do 28 i=1,np 28 py(i,j,k)= c22(i,j,k)*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=ibcy*c22(i,1,k)*(p(i,1+j3,k)-p(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=ibcy*c22(i,mp,k)*(p(i,mp+1+j3,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif if(ibcz.eq.1) then do 3 j=1,mp do 3 i=1,np do k=2,l-1 pz(i,j,k)=c33(i,j,k)*(p(i,j,k+1)-p(i,j,k-1)) enddo pz(i,j,1)=c33(i,j,1)*(p(i,j,2)-p(i,j,l-1)) pz(i,j,l)=c33(i,j,l)*(p(i,j,2)-p(i,j,l-1)) 3 continue endif call updatelr(px,np,mp,l,np,mp,iupx) do 91 k=1,l do 91 j=1,mp do 91 i=illim,iulim 91 r(i,j,k)=px(i+1,j,k)-px(i-1,j,k) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*2.*px(2,j,k)+ . ibcx*(px(2,j,k)-px(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(ibcx-1)*2.*px(np-1,j,k)+ . ibcx*(px(np+2,j,k)-px(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then call updatebt(py,np,mp,l,np,mp,iupy) jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+(py(i,j+j3,k)-py(i,j-j3,k)) end do end do end do #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(1-ibcy)*2.*py(i,1+j3,k) . +ibcy*(py(i,1+j3,k)-py(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)+(ibcy-1)*2.*py(i,mp-j3,k) 2 +ibcy*(py(i,mp+1+j3,k)-py(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1,k )) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)-(py(i,mp,k)+py(i,mp-j3,k)) end do end do end if #endif endif if(ibcz.eq.1) then do 93 j=1,mp do 93 i=1,np do 931 k=2,l-1 931 r(i,j,k)=r(i,j,k)+(pz(i,j,k+1)-pz(i,j,k-1)) r(i,j,1)=r(i,j,1)+(pz(i,j, 2 )-pz(i,j,l-1)) r(i,j,l)=r(i,j,l)+(pz(i,j, 2 )-pz(i,j,l-1)) 93 continue endif 100 continue 101 continue #if (TIMEPLT == 1) call ttend(14) #endif return end subroutine precon_bcz(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . e(1-ih:np+ih, 1-ih:mp+ih, 0:l-1) ! local array dimension f(np,mp,0:l-1),dgh(np,mp,l), . g(npcz,mpcz,0:lcz-1,2),q(npcz,mpcz,lcz,4), . aa(npcz,mpcz,4) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l), ! local array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array real globmax data beta/-1.e15/ c data itr,line/8,0/ data itr,line/2,0/ c data itr,line/2,1/ c data itr,line/6,0/ det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 #if (TIMEPLT == 1) call ttbeg(15) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(15) #endif return endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif omg=.7 oms=1.-omg dxi2=0.25*dxi*dxi dyi2=0.25*dyi*dyi dzi2=0.25*dzi*dzi do k=1,l do j=1,mp do i=1,np cf00=d(i,j,k)*fd(i,j,k) c11(i,j,k)=cf00*a11(i,j,k)*dxi2 c22(i,j,k)=cf00*a22(i,j,k)*dyi2 c33(i,j,k)=cf00*a33(i,j,k)*dzi2 dgh(i,j,k)=0. po(i,j,k)=0. p(i,j,k)=0. r(i,j,k)=0. enddo enddo enddo if(line.eq.1) then call updatelr(c11,np,mp,l,np,mp,iupx) call updatebt(c22,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim dgh(i,j,k)=c11(i+1,j,k)+c11(i-1,j,k) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dgh(1,j,k)=c11(2,j,k)+ibcx*c11(-1,j,k) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp dgh(np,j,k)=ibcx*c11(np+2,j,k)+c11(np-1,j,k) enddo enddo end if #endif if(j3.eq.1) then do k=1,l do j=jllim,julim do i=1,np dgh(i,j,k)=dgh(i,j,k)+c22(i,j+j3,k)+c22(i,j-j3,k) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dgh(i,1,k)=dgh(i,1,k)+c22(i,1+j3,k)+ibcy*c22(i,-j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dgh(i,mp,k)=dgh(i,mp,k)+ibcy*c22(i,mp+1+j3,k)+c22(i,mp-j3,k) enddo enddo end if #endif endif endif if(jfl.eq.0) then if(line.eq.0) then beta=-1.e15 do k=1,l do j=1,mp do i=1,np e(i,j,k-1)=( abs(c11(i,j,k))+abs(c22(i,j,k)) )/d(i,j,k) enddo enddo enddo beta=amax1(globmax(e,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . beta) beta=0.5/beta else beta=1. endif #if (TIMEPLT == 1) call ttend(15) #endif return endif beti=1./beta*(1-line) do 100 it=1,itr do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+d(i,j,k)*(beti*p(i,j,k)-rhs(i,j,k)) . +dgh(i,j,k)*p(i,j,k) enddo enddo enddo IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np e(i,j,0)=1. f(i,j,0)=0. dn=d(i,j,1)*beti+2.*c33(i,j,2)+dgh(i,j,1) e(i,j,1)=2.*c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn enddo enddo do k=2,l-1 do j=1,mp do i=1,np dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn enddo enddo enddo do j=1,mp do i=1,np dn=d(i,j,l)*beti+2.*(1.-e(i,j,l-2))*c33(i,j,l-1) . + dgh(i,j,l) p(i,j,l)=(r(i,j,l)+2.*f(i,j,l-2)*c33(i,j,l-1))/dn p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) enddo enddo do k=l-2,1,-1 do j=1,mp do i=1,np p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE i1=ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz e(i,j,0)=0. f(i,j,0)=0. dn=c33(i,j,2)+c33(i,j,l-1)+d(i,j,1)*beti+dgh(i,j,1) e(i,j,1)= c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn g(i,j,0 ,1)=1. g(i,j,i1,1)=0. g(i,j,0 ,2)=0. g(i,j,i1,2)= c33(i,j,l-1)/dn enddo enddo il=(1-ibcz)*2+ibcz*(lcz-ibcz) ! (2 or l-1) remove compiler wornings do k=2,il do j=1,mpcz do i=1,npcz dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn g(i,j,k,1)=(c33(i,j,k-1)*g(i,j,k-2,1) )/dn g(i,j,k,2)=(c33(i,j,k-1)*g(i,j,k-2,2) )/dn enddo enddo enddo il=lcz-ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz p(i,j,lcz )=0. p(i,j,il )=f(i,j,il) q(i,j,lcz,1)=0. q(i,j,il ,1)=g(i,j,il,1) q(i,j,lcz,2)=1. q(i,j,il ,2)=0. q(i,j,lcz,3)=0. q(i,j,il ,3)=g(i,j,il,2) q(i,j,lcz,4)=0. q(i,j,il ,4)=e(i,j,il) enddo enddo il=(1-ibcz)+ibcz*(lcz-2*ibcz) ! (l-2 or 1) remove compiler wornings do k=il,1,-ibcz do j=1,mpcz do i=1,npcz p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) q(i,j,k,1)=e(i,j,k)*q(i,j,k+2,1)+g(i,j,k,1) q(i,j,k,2)=e(i,j,k)*q(i,j,k+2,2) q(i,j,k,3)=e(i,j,k)*q(i,j,k+2,3)+g(i,j,k,2) q(i,j,k,4)=e(i,j,k)*q(i,j,k+2,4) enddo enddo enddo il1=lcz-ibcz ! remove compiler wornings for exceed array dimension il2=lcz-2*ibcz ! remove compiler wornings for exceed array dimension i2 =1+ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz d11= q(i,j,il1,1)-1. d12= q(i,j,il1,2) d13= q(i,j,il1,3) d14= q(i,j,il1,4) s1 =-p(i,j,il1) d21= q(i,j,1,1) d22= q(i,j,1,2)-1. d23= q(i,j,1,3) d24= q(i,j,1,4) s2 =-p(i,j,1) d31= q(i,j,il2,1) d32= q(i,j,il2,2) d33= q(i,j,il2,3)-1. d34= q(i,j,il2,4) s3 =-p(i,j,il2) d41= q(i,j,i2,1) d42= q(i,j,i2,2) d43= q(i,j,i2,3) d44= q(i,j,i2,4)-1. s4 =-p(i,j,i2) det40=d11*det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -d21*det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +d31*det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -d41*det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) deti=1./det40 det41=s1 *det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -s2 *det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +s3 *det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -s4 *det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) det42=d11*det3( s2,d23,d24, s3,d33,d34, s4,d43,d44) . -d21*det3( s1,d13,d14, s3,d33,d34, s4,d43,d44) . +d31*det3( s1,d13,d14, s2,d23,d24, s4,d43,d44) . -d41*det3( s1,d13,d14, s2,d23,d24, s3,d33,d34) det43=d11*det3(d22, s2,d24,d32, s3,d34,d42, s4,d44) . -d21*det3(d12, s1,d14,d32, s3,d34,d42, s4,d44) . +d31*det3(d12, s1,d14,d22, s2,d24,d42, s4,d44) . -d41*det3(d12, s1,d14,d22, s2,d24,d32, s3,d34) det44=d11*det3(d22,d23, s2,d32,d33, s3,d42,d43, s4) . -d21*det3(d12,d13, s1,d32,d33, s3,d42,d43, s4) . +d31*det3(d12,d13, s1,d22,d23, s2,d42,d43, s4) . -d41*det3(d12,d13, s1,d22,d23, s2,d32,d33, s3) aa(i,j,4)=det44*deti aa(i,j,3)=det43*deti aa(i,j,2)=det42*deti aa(i,j,1)=det41*deti enddo enddo do k=1,lcz do j=1,mpcz do i=1,npcz p(i,j,k)=p(i,j,k)+aa(i,j,1)*q(i,j,k,1) . +aa(i,j,2)*q(i,j,k,2) . +aa(i,j,3)*q(i,j,k,3) . +aa(i,j,4)*q(i,j,k,4) enddo enddo enddo correct for round-off departures from the cyclicity in the vertical do j=1,mpcz do i=1,npcz p(i,j,l)=p(i,j,1) enddo enddo ENDIF if(line.eq.1) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=oms*po(i,j,k)+omg*p(i,j,k) po(i,j,k)= p(i,j,k) enddo enddo enddo endif if(ibcz.eq.1) then do j=1,mp do i=1,np p(i,j,l)=p(i,j,1) end do end do endif call update2(p,np,mp,l,np,mp,iup) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.1) then do k=1,l do j=1,mp p(np,j,k)=p(np+1,j,k) end do end do end if endif if(ibcy.eq.1) then if (topedge.eq.1) then do k=1,l do i=1,np p(i,mp,k)=p(i,mp+1,k) end do end do end if endif #endif if(it.eq.itr) go to 101 do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim px(i,j,k)=c11(i,j,k)*(p(i+1,j,k)-p(i-1,j,k)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=ibcx*c11(1,j,k)*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=ibcx*c11(np,j,k)*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 28 k=1,l do 28 j=jllim,julim do 28 i=1,np 28 py(i,j,k)= c22(i,j,k)*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=ibcy*c22(i,1,k)*(p(i,1+j3,k)-p(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=ibcy*c22(i,mp,k)*(p(i,mp+1+j3,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif call updatelr(px,np,mp,l,np,mp,iupx) do 91 k=1,l do 91 j=1,mp do 91 i=illim,iulim 91 r(i,j,k)=px(i+1,j,k)-px(i-1,j,k) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*2.*px(2,j,k)+ . ibcx*(px(2,j,k)-px(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(ibcx-1)*2.*px(np-1,j,k)+ . ibcx*(px(np+2,j,k)-px(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then C-------------------------------------------- C At the poles C py=dp/dy C d(py)/dy=0 C-------------------------------------------- call updatebt(py,np,mp,l,np,mp,iupy) jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+(py(i,j+j3,k)-py(i,j-j3,k)) end do end do end do #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(1-ibcy)*2.*py(i,1+j3,k) . +ibcy*(py(i,1+j3,k)-py(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)+(ibcy-1)*2.*py(i,mp-j3,k) 2 +ibcy*(py(i,mp+1+j3,k)-py(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1-j3,k )) r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1,k )) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-(py(i,mp+j3,k)+py(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-(py(i,mp,k)+py(i,mp-j3,k)) end do end do end if #endif endif 100 continue 101 continue #if (TIMEPLT == 1) call ttend(15) #endif return end #endif /* PRECF=0 */ #if(PRECF > 0) subroutine precon_f(rhs,p,r,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . tmp1(1-ih:np+ih, 1-ih:mp+ih), . tmp2(1-ih:np+ih, 1-ih:mp+ih), . tmp3(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) dimension ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp) common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l,4) ! local array real globsum #if (TIMEPLT == 1) call ttbeg(16) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(16) #endif return endif if(jfl.eq.0) then fnmi=1./float(n*m) fdzi25=0.25*dzi*dzi*fnmi do k=1,l temp1=0. temp2=0. temp3=0. do j=1,mp do i=1,np p(i,j,k)=0. r(i,j,k)=d(i,j,k)*rhs(i,j,k) temp1=temp1+d(i,j,k)*fd(i,j,k)*a11(i,j,k) temp2=temp2+d(i,j,k)*fd(i,j,k)*a22(i,j,k) temp3=temp3+d(i,j,k)*fd(i,j,k)*a33(i,j,k) end do end do c11(k)=globsum(temp1,1,1,1,1,1,1,1,1,1,1,1,1) c22(k)=globsum(temp2,1,1,1,1,1,1,1,1,1,1,1,1) c33(k)=globsum(temp3,1,1,1,1,1,1,1,1,1,1,1,1) c11(k)=c11(k)*fnmi c22(k)=c22(k)*fnmi c33(k)=c33(k)*fdzi25 enddo #if (TIMEPLT == 1) call ttend(16) #endif return endif do k=1,l do j=1,mp do i=1,np p(i,j,k)=0. r(i,j,k)=-d(i,j,k)*rhs(i,j,k) end do end do end do #if (TIMEPLT == 1) call ttend(16) #endif call fourier(r,ar,ai,br,bi,1) c ------> solve 3-diagonal problems for Fourier amplitudes call tridg(ar) IF(IBCX*IBCY.EQ.1) THEN call tridg(ai) call tridg(br) call tridg(bi) ENDIF IF(IBCX.EQ.1.and.IBCY.EQ.0) THEN call tridg(bi) ENDIF IF(IBCX.EQ.0.and.IBCY.EQ.1) THEN call tridg(br) ENDIF call fourieri(p,ar,ai,br,bi,-1) return end subroutine fourier(r,ar,ai,br,bi,iflg) include 'param.nml' include 'msg.inc' include 'param.ior' #if (PARALLEL > 0) #include "msg.lnk" #endif dimension r(1-ih:np+ih, 1-ih:mp+ih, l), 1 ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp), #if (PARALLEL == 0) 2 ari(nssp, mssp), 2 aii(nssp, mssp), 2 bri(nssp, mssp), 2 bii(nssp, mssp), 2 arj(nssp, mspp), 2 aij(nssp, mspp), 2 brj(nssp, mspp), 2 bij(nssp, mspp) #else 2 dri(nssp, mssp, nprocy, 4), 2 cri(mspp, nssp, nprocx, 4) #endif common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(17) #endif compute Fourier transform #if (POLES == 0) iulimc = np - rightedge*ibcx julimc = mp - topedge*ibcy #else iulimc = np julimc = mp #endif IF(IBCX*IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. cri(j,ii,is,2)=0. cri(j,ii,is,3)=0. cri(j,ii,is,4)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,2)=cri(j,ii,is,2)+r(i,j,k)*sinx(i,ii,is) cri(j,ii,is,3)=cri(j,ii,is,3)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,4)=cri(j,ii,is,4)+r(i,j,k)*sinx(i,ii,is) end do end do end do end do nx=mp*nssp*nprocxp*4 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:4), . cri(1:mspp,1:nssp,1:nprocxp,1:4), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. dri(ii,jj,js,3)=0. dri(ii,jj,js,4)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1)+cri(j,ii,npos,1)*cosy(j,jj,js) dri(ii,jj,js,2)=dri(ii,jj,js,2)+cri(j,ii,npos,2)*siny(j,jj,js) dri(ii,jj,js,3)=dri(ii,jj,js,3)+cri(j,ii,npos,3)*siny(j,jj,js) dri(ii,jj,js,4)=dri(ii,jj,js,4)+cri(j,ii,npos,4)*cosy(j,jj,js) end do enddo end do end do nx=mssp*nssp*nprocyp*4 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:4), . dri(1:nssp,1:mssp,1:nprocyp,1:4), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) ai(ii,jj,k)=dri(ii,jj,mpos,2) br(ii,jj,k)=dri(ii,jj,mpos,3) bi(ii,jj,k)=dri(ii,jj,mpos,4) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. aij(ii,j)=0. brj(ii,j)=0. bij(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1) aij(ii,j)=aij(ii,j)+r(i,j,k)*sinx(i,ii,1) brj(ii,j)=brj(ii,j)+r(i,j,k)*cosx(i,ii,1) bij(ii,j)=bij(ii,j)+r(i,j,k)*sinx(i,ii,1) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. ai(ii,jj,k)=0. br(ii,jj,k)=0. bi(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1) ai(ii,jj,k)=ai(ii,jj,k)+aij(ii,j)*siny(j,jj,1) br(ii,jj,k)=br(ii,jj,k)+brj(ii,j)*siny(j,jj,1) bi(ii,jj,k)=bi(ii,jj,k)+bij(ii,j)*cosy(j,jj,1) end do enddo end do #endif ENDDO ENDIF IF(IBCX.EQ.1.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. cri(j,ii,is,2)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,2)=cri(j,ii,is,2)+r(i,j,k)*sinx(i,ii,is) end do end do end do end do nx=mp*nssp*nprocxp*2 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:2), . cri(1:mspp,1:nssp,1:nprocxp,1:2), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1) . +cri( j,ii,npos,1)*cosy(j,jj,js)*gy(j) dri(ii,jj,js,2)=dri(ii,jj,js,2) . +cri( j,ii,npos,2)*cosy(j,jj,js)*gy(j) end do enddo end do end do nx=mssp*nssp*nprocyp*2 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:2), . dri(1:nssp,1:mssp,1:nprocyp,1:2), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) bi(ii,jj,k)=dri(ii,jj,mpos,2) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. bij(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1) bij(ii,j)=bij(ii,j)+r(i,j,k)*sinx(i,ii,1) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. bi(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1)*gy(j) bi(ii,jj,k)=bi(ii,jj,k)+bij(ii,j)*cosy(j,jj,1)*gy(j) end do enddo end do #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is)*gx(i) end do end do end do end do nx=mp*nssp*nprocxp*1 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:1), . cri(1:mspp,1:nssp,1:nprocxp,1:1), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1)+cri(j,ii,npos,1)*cosy(j,jj,js) dri(ii,jj,js,2)=dri(ii,jj,js,2)+cri(j,ii,npos,1)*siny(j,jj,js) end do enddo end do end do nx=mssp*nssp*nprocyp*2 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:2), . dri(1:nssp,1:mssp,1:nprocyp,1:2), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) br(ii,jj,k)=dri(ii,jj,mpos,2) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1)*gx(i) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. br(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1) br(ii,jj,k)=br(ii,jj,k)+arj(ii,j)*siny(j,jj,1) end do enddo end do #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is)*gx(i) end do end do end do end do nx=mp*nssp*nprocxp*1 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:1), . cri(1:mspp,1:nssp,1:nprocxp,1:1), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1) . +cri( j,ii,npos,1)*cosy(j,jj,js)*gy(j) end do enddo end do end do nx=mssp*nssp*nprocyp*1 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:1), . dri(1:nssp,1:mssp,1:nprocyp,1:1), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1)*gx(i) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1)*gy(j) end do enddo end do #endif ENDDO ENDIF #if (TIMEPLT == 1) call ttend(17) #endif return end subroutine fourieri(r,ar,ai,br,bi,iflg) include 'param.nml' include 'msg.inc' include 'param.ior' #if (PARALLEL > 0) #include "msg.lnk" #endif dimension r(1-ih:np+ih, 1-ih:mp+ih, l), 1 ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp), #if (PARALLEL == 0) 2 prj(mssp, nspp), 2 pij(mssp, nspp), 2 qrj(mssp, nspp), 2 qij(mssp, nspp) #else 2 xii(mssp, nspp, nprocx, 4), 2 rii(nspp, mspp, nprocy) #endif common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(18) #endif compute inverse Fourier transform !synthesis IF(IBCX*IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. xii(jj,i,is,3)=0. xii(jj,i,is,4)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+ai(ii,jj,k)*sinxi(i,ii,is) xii(jj,i,is,3)=xii(jj,i,is,3)+br(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,4)=xii(jj,i,is,4)+bi(ii,jj,k)*sinxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*4 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:4), . xii(1:mssp,1:nspp,1:nprocx,1:4), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*4 call MPI_SEND(xii(1:mssp,1:nspp,irpos:irpos,1:4), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,ier) endif else nx=mssp*np*4 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:4), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do js=1,nprocy ! physiscal space do j=1,mp do i=1,np rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*sinyi(j,jj,js) . +xii(jj,i,npos,3)*sinyi(j,jj,js) . +xii(jj,i,npos,4)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_SEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do j=1,mp do i=1,np r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp ! local spectral space mmp prj(jj,i)=0. pij(jj,i)=0. qrj(jj,i)=0. qij(jj,i)=0. do ii=1,nnp ! nnp spectral space prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) pij(jj,i)=pij(jj,i)+ai(ii,jj,k)*sinxi(i,ii,1) qrj(jj,i)=qrj(jj,i)+br(ii,jj,k)*cosxi(i,ii,1) qij(jj,i)=qij(jj,i)+bi(ii,jj,k)*sinxi(i,ii,1) enddo enddo enddo do i=1,np do j=1,mp r(i,j,k)=0. do jj=1,mmp ! spectral space r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +pij(jj,i)*sinyi(j,jj,1) . +qrj(jj,i)*sinyi(j,jj,1) . +qij(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.1.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+bi(ii,jj,k)*sinxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*2 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:2), . xii(1:mssp,1:nspp,1:nprocx,1:2), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*2 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:2), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*2 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:2), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. qij(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) qij(jj,i)=qij(jj,i)+bi(ii,jj,k)*sinxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +qij(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+br(ii,jj,k)*cosxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*2 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:2), . xii(1:mssp,1:nspp,1:nprocx,1:2), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*2 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:2), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*2 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:2), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*sinyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. qrj(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) qrj(jj,i)=qrj(jj,i)+br(ii,jj,k)*cosxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +qrj(jj,i)*sinyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*1 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:1), . xii(1:mssp,1:nspp,1:nprocx,1:1), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*1 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:1), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*1 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:1), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF #if (TIMEPLT == 1) call ttend(18) #endif return end CDPR double precision function CDPR 1 det3(r11,r12,r13,r21,r22,r23,r31,r32,r33) CDPR double precision r11,r12,r13,r21,r22,r23,r31,r32,r33 CDPR CDPR det3=r11*r22*r33+r12*r23*r31+r13*r21*r32 CDPR . -r31*r22*r13-r32*r23*r11-r33*r21*r12 CDPR CDPR return CDPR end subroutine tridg(p) include 'param.nml' include 'msg.inc' common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc dimension p(nssp, mssp, lssp), . e(nssp, mssp, 0:lssp-1), . f(nssp, mssp, 0:lssp-1), . g(nssp, mssp, 0:lssp-1, 2), . q(nssp, mssp, lssp, 4), . aa(nssp, mssp, 4) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C dimension p(1-ih:nssp+ih, 1-ih:mssp+ih, lcz), C . e(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1), C . f(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1), C . g(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1, 2), C . q(1-ih:nssp+ih, 1-ih:mssp+ih, lcz, 4), C . aa(1-ih:nssp+ih, 1-ih:mssp+ih, 4) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc CDPR double precision dn,dgh CDPR double precision deti,det40,det41,det42,det43,det44,det3, CDPR . d11,d21,d31,d41, CDPR . d12,d22,d32,d42, CDPR . d13,d23,d33,d43, CDPR . d14,d24,d34,d44, CDPR . s1 ,s2 ,s3 ,s4 det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 #if (TIMEPLT == 1) call ttbeg(19) #endif if((nnp.lt.1).or.(mmp.lt.1)) return IF(IBCZ.EQ.0) THEN do j=1,mmp do i=1,nnp e(i,j,0)=1. f(i,j,0)=0. dgh=c11(1)*egx(i,j)+c22(1)*egy(i,j) dn=1./(2.*c33(2)+dgh) e(i,j,1)=2.*c33(2)*dn f(i,j,1)= p(i,j,1)*dn enddo enddo do k=2,l-1 do j=1,mmp do i=1,nnp dgh=c11(k)*egx(i,j)+c22(k)*egy(i,j) dn=1./(c33(k+1)+c33(k-1)*(1.-e(i,j,k-2))+dgh) e(i,j,k)= c33(k+1)*dn f(i,j,k)=(c33(k-1)*f(i,j,k-2)+p(i,j,k))*dn enddo enddo enddo do j=1,mmp do i=1,nnp dgh=c11(l)*egx(i,j)+c22(l)*egy(i,j) dn=2.*(1.-e(i,j,l-2))*c33(l-1)+dgh CDPR if(dabs(dn).gt.1.e-10) then if( abs(dn).gt.1.e-10) then p(i,j,l)=(p(i,j,l)+2.*f(i,j,l-2)*c33(l-1))/dn else p(i,j,l)=0. endif if(abs(1.-e(i,j,l-1)).gt.1.e-10) then p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) else p(i,j,l-1)=0. endif enddo enddo do k=l-2,1,-1 do j=1,mmp do i=1,nnp p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE !periodic tridiagonal solver do j=1,mmp do i=1,nnp e(i,j,0)=0. f(i,j,0)=0. dgh=c11(1)*egx(i,j)+c22(1)*egy(i,j) dn=1./(c33(2)+c33(l-1)+dgh) e(i,j,1)= c33(2)*dn f(i,j,1)= p(i,j,1)*dn g(i,j,0,1)=1. g(i,j,1,1)=0. g(i,j,0,2)=0. g(i,j,1,2)= c33(l-1)*dn enddo enddo do k=2,l-1 do j=1,mmp do i=1,nnp dgh=c11(k)*egx(i,j)+c22(k)*egy(i,j) dn=1./(c33(k+1)+c33(k-1)*(1.-e(i,j,k-2))+dgh) e(i,j,k) = c33(k+1)*dn f(i,j,k) =(c33(k-1)*f(i,j,k-2)+p(i,j,k))*dn g(i,j,k,1)=(c33(k-1)*g(i,j,k-2,1) )*dn g(i,j,k,2)=(c33(k-1)*g(i,j,k-2,2) )*dn enddo enddo enddo do j=1,mmp do i=1,nnp p(i,j, l )=0. p(i,j,l-1 )=f(i,j,l-1) q(i,j, l ,1)=0. q(i,j,l-1,1)=g(i,j,l-1,1) q(i,j, l ,2)=1. q(i,j,l-1,2)=0. q(i,j, l ,3)=0. q(i,j,l-1,3)=g(i,j,l-1,2) q(i,j, l ,4)=0. q(i,j,l-1,4)=e(i,j,l-1) enddo enddo do k=l-2,1,-1 do j=1,mmp do i=1,nnp p(i,j,k )=e(i,j,k)*p(i,j,k+2 )+f(i,j,k) q(i,j,k,1)=e(i,j,k)*q(i,j,k+2,1)+g(i,j,k,1) q(i,j,k,2)=e(i,j,k)*q(i,j,k+2,2) q(i,j,k,3)=e(i,j,k)*q(i,j,k+2,3)+g(i,j,k,2) q(i,j,k,4)=e(i,j,k)*q(i,j,k+2,4) enddo enddo enddo do j=1,mmp do i=1,nnp d11= q(i,j,l-1,1)-1. d12= q(i,j,l-1,2) d13= q(i,j,l-1,3) d14= q(i,j,l-1,4) d21= q(i,j,1,1) d22= q(i,j,1,2)-1. d23= q(i,j,1,3) d24= q(i,j,1,4) d31= q(i,j,l-2,1) d32= q(i,j,l-2,2) d33= q(i,j,l-2,3)-1. d34= q(i,j,l-2,4) d41= q(i,j,2,1) d42= q(i,j,2,2) d43= q(i,j,2,3) d44= q(i,j,2,4)-1. det40=d11*det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -d21*det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +d31*det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -d41*det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) CDPR if(dabs(det40).lt.1.e-10) then if( abs(det40).lt.1.e-10) then aa(i,j,4)=0. aa(i,j,3)=0. aa(i,j,2)=0. aa(i,j,1)=0. else s1 =-p(i,j,l-1) s2 =-p(i,j,1) s3 =-p(i,j,l-2) s4 =-p(i,j,2) deti=1./det40 det41=s1 *det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -s2 *det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +s3 *det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -s4 *det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) det42=d11*det3( s2,d23,d24, s3,d33,d34, s4,d43,d44) . -d21*det3( s1,d13,d14, s3,d33,d34, s4,d43,d44) . +d31*det3( s1,d13,d14, s2,d23,d24, s4,d43,d44) . -d41*det3( s1,d13,d14, s2,d23,d24, s3,d33,d34) det43=d11*det3(d22, s2,d24,d32, s3,d34,d42, s4,d44) . -d21*det3(d12, s1,d14,d32, s3,d34,d42, s4,d44) . +d31*det3(d12, s1,d14,d22, s2,d24,d42, s4,d44) . -d41*det3(d12, s1,d14,d22, s2,d24,d32, s3,d34) det44=d11*det3(d22,d23, s2,d32,d33, s3,d42,d43, s4) . -d21*det3(d12,d13, s1,d32,d33, s3,d42,d43, s4) . +d31*det3(d12,d13, s1,d22,d23, s2,d42,d43, s4) . -d41*det3(d12,d13, s1,d22,d23, s2,d32,d33, s3) aa(i,j,4)=det44*deti aa(i,j,3)=det43*deti aa(i,j,2)=det42*deti aa(i,j,1)=det41*deti endif enddo enddo do k=1,l do j=1,mmp do i=1,nnp p(i,j,k)=p(i,j,k)+aa(i,j,1)*q(i,j,k,1) . +aa(i,j,2)*q(i,j,k,2) . +aa(i,j,3)*q(i,j,k,3) . +aa(i,j,4)*q(i,j,k,4) enddo enddo enddo correct for round-off departures from the cyclicity in the vertical do j=1,mmp do i=1,nnp p(i,j,l)=p(i,j,1) enddo enddo ENDIF #if (TIMEPLT == 1) call ttend(19) #endif return end subroutine spcpri include 'param.nml' include 'msg.inc' common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(20) #endif c precompute trygonometric coefficients pi=acos(-1.) pi2=2.*pi pih=pi/2. piho=1./pih pi2o=1./pi2 xnm=1./float(N-1) ynm=1./float(M-1) #if (POLES == 0) nn=(n+1)/2*ibcx+(1-ibcx)*n mm=(m+1)/2*ibcy+(1-ibcy)*m #else nn=(n+1)/2 mm=(m+1)/2 #endif nnp=max(0,min(nssp,nn-(npos-1)*np)) ! local value of nn mmp=max(0,min(mssp,mm-(mpos-1)*mp)) ! local value of mm ism=max(ispcpr,0) ! nprocxp - no of processors covering spectral domian in X ! nprocyp - no of processors covering spectral domian in Y nprocxp=nint(float(nn)/float(np)+.49999999)*ism+(1-ism) nprocyp=nint(float(mm)/float(mp)+.49999999)*ism+(1-ism) do i=1,nspct xmsk(i)=0. enddo do ii=1,nn xmsk(ii)=1. enddo do i=1,nssp ia=(npos-1)*np + i if(xmsk(ia).eq.1.) wx(i)=2. if(xmsk(ia).eq.0.) wx(i)=0. enddo #if (POLES == 0) if(ibcx.eq.1) then if(leftedge.eq.1) wx(1)=1 ! wx(1)=1 if(mod(n,2).eq.1) then do i=1,nssp ia=(npos-1)*np + i if(ia.eq.nn) wx(i)=1. ! wx(nn)=1 enddo endif else if(leftedge.eq.1) wx(1)=1. ! wx(1)=1 do i=1,nssp ia=(npos-1)*np + i if(ia.eq.nn) wx(i)=1. ! wx(nn)=1 enddo endif #endif do j=1,mspct ymsk(j)=0. enddo do jj=1,mm ymsk(jj)=1. enddo do j=1,mssp ja=(mpos-1)*mp + j if(ymsk(ja).eq.(1.)) wy(j)=2. if(ymsk(ja).eq.(0.)) wy(j)=0. enddo #if (POLES == 0) if(ibcy.eq.1) then if(botedge.eq.1) wy(1)=1 ! wy(1)=1 if(mod(m,2).eq.1) then do j=1,mssp ja=(mpos-1)*mp + j if(ja.eq.mm) wy(j)=1. ! wy(mm)=1 enddo endif else if(botedge.eq.1) wy(1)=1 ! wy(1)=1 do j=1,mssp ja=(mpos-1)*mp + j if(ja.eq.mm) wy(j)=1. ! wy(mm)=1 enddo endif #endif IF(IBCX.EQ.1) THEN do is=1,nprocx do ii=1,nssp iia=(is-1)*np+ii do i=1,np gx(i)=1. ia=(npos-1)*np + i cosx(i,ii,is)=cos(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm sinx(i,ii,is)=sin(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm enddo enddo enddo do ii=1,nssp iia=(npos-1)*np+ii do is=1,nprocx do i=1,np ia=(is-1)*np + i cosxi(i,ii,is)=cos(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) sinxi(i,ii,is)=sin(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) enddo enddo enddo ELSE do is=1,nprocx do ii=1,nssp iia=(is-1)*np+ii do i=1,np gx(i)=1. ia=(npos-1)*np + i cosx(i,ii,is)=cos(pi*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm enddo enddo enddo do ii=1,nssp iia=(npos-1)*np+ii do is=1,nprocx do i=1,np ia=(is-1)*np + i cosxi(i,ii,is)=cos(pi*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) enddo enddo enddo if (leftedge.eq.1) gx( 1)=.5 if (rightedge.eq.1) gx(np)=.5 ENDIF IF(IBCY.EQ.1) THEN do js=1,nprocy do jj=1,mssp jja=(js-1)*mp + jj do j=1,mp gy(j)=1. ja=(mpos-1)*mp + j cosy(j,jj,js)=cos(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm siny(j,jj,js)=sin(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm enddo enddo enddo do jj=1,mssp jja=(mpos-1)*mp + jj do js=1,nprocy do j=1,mp ja=(js-1)*mp + j cosyi(j,jj,js)=cos(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) sinyi(j,jj,js)=sin(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) enddo enddo enddo ELSE do js=1,nprocy do jj=1,mssp jja=(js-1)*mp + jj do j=1,mp gy(j)=1. ja=(mpos-1)*mp + j cosy(j,jj,js)=cos(pi*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm enddo enddo enddo do jj=1,mssp jja=(mpos-1)*mp + jj do js=1,nprocy do j=1,mp ja=(js-1)*mp + j cosyi(j,jj,js)=cos(pi*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) enddo enddo enddo if (botedge.eq.1) gy( 1)=.5 if (topedge.eq.1) gy(mp)=.5 endif #if (POLES == 0) if(ibcx*ibcy.eq.1) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.1.and.ibcy.eq.0) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi *(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.0.and.ibcy.eq.1) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi *(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.0.and.ibcy.eq.0) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi *(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi *(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif #else do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo #endif #if (TIMEPLT == 1) call ttend(20) #endif return end #endif /* PRECF > 0 */ subroutine laplc(p,r,u,v,w,fd,ibf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> x, r . r(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> ax, ar . u(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfx . v(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfy . w(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: fz common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip !mod bbc common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/slipb/ noslipb common/indx/ e1,e2,e3 common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . scr3(1-ih:np+ih,1-ih:mp+ih,l), ! not used . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:np+ih+1,1-ih:mp+ih+1,l+1) ! local array #if (TIMEPLT == 1) call ttbeg(21) #endif c do 77 k=1,l c do 77 j=1,mp c do 77 i=1,np c ia=(npos-1)*np + i c ja=(mpos-1)*mp + j c 77 p(i,j,k)=1.e-8*float(ia*ja*k*k)/float(n*m*l) call update2(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)= dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp - j3*topedge #else jllim = 1 julim = mp #endif do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do j=1,mp do i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) end do end do else do j=1,mp do i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) end do end do endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if (PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if (PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,1) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pz(i,j,k)) v(i,j,k)=-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pz(i,j,k)) w(i,j,k)=-(c31*px(i,j,k)+c32*py(i,j,k)+c33*pz(i,j,k)) 10 continue compute pressure forces at the boundaries #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge do 11 i=illim,iulim,np-1 cdel ii=1+i/np do 111 j=jllim,julim do 111 k=2-ibcz,l-1+ibcz c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=0. pxb=-(c12*py(i,j,k)+c13*pz(i,j,k))/c11 v(i,j,k)=-(c21*pxb+c22*py(i,j,k)+c23*pz(i,j,k)) 111 w(i,j,k)=-(c31*pxb+c32*py(i,j,k)+c33*pz(i,j,k))*icw 11 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 112 i=illim,iulim,np-1 cdel ii=1+i/np do 112 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=0. v(i,j,k)=0. a=-c13*pz(i,j,k) b=-c23*pz(i,j,k) pxb=(c22*a-c12*b)/(c11*c22-c12*c21) pyb=(c11*b-c21*a)/(c11*c22-c12*c21) 1121 w(i,j,k)=-(c31*pxb+c32*pyb+c33*pz(i,j,k)) 112 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge do 12 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) v(i,j,k)= 0. pyb=-(c21*px(i,j,k)+c23*pz(i,j,k))/c22 u(i,j,k)=-(c11*px(i,j,k)+c12*pyb+c13*pz(i,j,k)) 121 w(i,j,k)=-(c31*px(i,j,k)+c32*pyb+c33*pz(i,j,k))*icw 12 continue endif #endif if(ibcz.eq.0) then #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge #else jllim = 1 julim = mp illim = 1 iulim = np #endif do 20 k=1,l,l-1 cdel kk=1+k/l do 21 j=jllim,julim do 21 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. pzb=-(c31*px(i,j,k)+c32*py(i,j,k))/c33 u(i,j,k)=-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pzb) v(i,j,k)=-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pzb) 21 continue 20 continue #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if do 211 k=1,l,l-1 cdel kk=1+k/l do 211 i=illim,iulim,np-1 cdel ii=1+i/np do 2111 j=jllim,julim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. u(i,j,k)=0. pzb=-(c11*c32-c31*c12)*py(i,j,k)/(c11*c33-c31*c13) pxb=-(c12*py(i,j,k)+c13*pzb)/c11 2111 v(i,j,k)=-(c21*pxb+c22*py(i,j,k)+c23*pzb) 211 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 212 k=1,l,l-1 do 212 i=illim,iulim,np-1 do 212 j=jllim,julim,mp-j3 cdel jj=1+j/mp w(i,j,k)=0. u(i,j,k)=0. 212 v(i,j,k)=0. endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 221 k=1,l,l-1 cdel kk=1+k/l do 221 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 221 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. v(i,j,k)=0. pzb=-(c31*c22-c32*c21)*px(i,j,k)/(c33*c22-c32*c23) pyb=-(c21*px(i,j,k)+c23*pzb)/c22 221 u(i,j,k)=-(c11*px(i,j,k)+c12*pyb+c13*pzb) endif ! ibcy.eq.0.and.j3.eq.1 #endif endif ! ibcz.eq.0 do 99 k=1,l do 99 j=1,mp do 99 i=1,np cf00=d(i,j,k)*fd(i,j,k) u(i,j,k)=cf00*u(i,j,k) v(i,j,k)=cf00*v(i,j,k) 99 w(i,j,k)=cf00*w(i,j,k) if(noslip.eq.1) then #if (POLES == 0) customized for QBO lab experiment, noslip y boundaries, and zbar=0 as an option if(leftedge.eq.1) then do k=1,l do j=1,mp c u(1,j,k)=0. v(1,j,k)=0. w(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c u(np,j,k)=0. v(np,j,k)=0. w(np,j,k)=0. enddo enddo endif #endif c---> noslip lower boundary do j=1,mp do i=1,np u(i,j,1)=0. v(i,j,1)=0. c u(i,j,l)=0. c v(i,j,l)=0. enddo enddo endif !mod bbc ! if(ibf.eq.2.and.noslipb.eq.1) then if(ibf.eq.2) then c---> noslipb boundary (vertical magnetic field) if (ibbl .eq. 1) then u(i,j,1)=0. v(i,j,1)=0. endif if (ibbu .eq. 1) then u(i,j,l)=0. v(i,j,l)=0. endif ! if (noslipb.eq.1) then ! do j=1,mp ! do i=1,np ! u(i,j,1)=0. ! v(i,j,1)=0. ! u(i,j,l)=0. ! v(i,j,l)=0. ! enddo ! enddo ! endif ! if (noslipb.eq.2) then ! do j=1,mp ! do i=1,np ! u(i,j,l)=0. ! v(i,j,l)=0. ! enddo ! enddo ! endif endif if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if(iencyc.eq.1) then c enforce cyclicity !mod if(ibcx.eq.1) then call updatelr(u,np,mp,l,np,mp,1) call updatelr(v,np,mp,l,np,mp,1) call updatelr(w,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp u(np,j,k)=u(np+1,j,k) v(np,j,k)=v(np+1,j,k) w(np,j,k)=w(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(u,np,mp,l,np,mp,1) call updatebt(v,np,mp,l,np,mp,1) call updatebt(w,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np u(i,mp,k)=u(i,mp+j3,k) v(i,mp,k)=v(i,mp+j3,k) w(i,mp,k)=w(i,mp+j3,k) enddo enddo endif endif endif !iencyc compute laplacian if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(u,np,mp,l,np,mp,iupx) call updatebt(v,np,mp,l,np,mp,iupy) #if (POLES == 0) if (leftedge.eq.0 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=1,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do end do end do else if (leftedge.eq.1 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=2,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(1,j,k)=(1-ibcx)*dxi*(u(2,j,k)-u( 1,j,k)) 2 +ibcx*dxil*(u(2,j,k)-u(-1,j,k)) end do end do else if (rightedge.eq.1 .and. leftedge.eq.0) then do k=1,l do j=1,mp do i=1,np-1 r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)-u(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)-u(np-1,j,k)) end do end do else if (rightedge.eq.1 .and. leftedge.eq.1) then do k=1,l do j=1,mp do i=2,np-1 r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(1 ,j,k)=(1-ibcx)*dxi*(u(2 ,j,k)-u( 1,j,k)) 2 +ibcx*dxil*(u(2 ,j,k)-u( -1,j,k)) r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)-u(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)-u(np-1,j,k)) end do end do end if #else do k=1,l do j=1,mp do i=1,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do end do end do #endif if(j3.eq.1) then #if (POLES == 0) if (topedge.eq.0 .and. botedge.eq.0) then do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do end do end do else if (botedge.eq.1 .and. topedge.eq.0) then do k=1,l do i=1,np do j=2,mp r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,1,k)=r(i,1,k)+(1-ibcy)*dyi*(v(i,1+j3,k)- . v(i,1,k)) 2 +ibcy*dyil*(v(i,1+j3,k)-v(i,-1,k)) end do end do else if (topedge.eq.1 .and. botedge.eq.0) then do k=1,l do i=1,np do j=1,mp-j3 r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,mp,k)=r(i,mp,k)+(1-ibcy)*dyi* . (v(i,mp,k)-v(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2,k)-v(i,mp-j3,k)) end do end do else if (topedge.eq.1 .and. botedge.eq.1) then do k=1,l do i=1,np do j=2,mp-j3 r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,1,k)=r(i,1,k)+(1-ibcy)*dyi*(v(i,1+j3,k)- . v(i,1,k)) 2 +ibcy*dyil*(v(i,1+j3,k)-v(i,-1,k)) r(i,mp,k)=r(i,mp,k)+(1-ibcy)*dyi* . (v(i,mp,k)-v(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2,k)-v(i,mp-j3,k)) end do end do end if #else jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)-v(i,j-j3,k)) end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+dyil*(v(i,1+j3,k)+v(i,1-j3,k)) r(i,1,k)=r(i,1,k)+dyil*(v(i,1+j3,k)+v(i,1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-dyil*(v(i,mp+j3,k)+v(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-dyil*(v(i,mp ,k)+v(i,mp-j3,k)) end do end do end if #endif endif do 93 k=2,l-1 do 93 j=1,mp do 93 i=1,np 93 r(i,j,k)=r(i,j,k)+dzil*(w(i,j,k+1)-w(i,j,k-1)) if(ibcz.eq.0) then do 931 j=1,mp do 931 i=1,np r(i,j,1)=r(i,j,1)+dzi*(w(i,j,2)-w(i,j,1)) r(i,j,l)=r(i,j,l)+dzi*(w(i,j,l)-w(i,j,l-1)) 931 continue else do 932 j=1,mp do 932 i=1,np r(i,j,1)=r(i,j,1)+dzil*(w(i,j,2)-w(i,j,l-1)) r(i,j,l)=r(i,j,l)+dzil*(w(i,j,2)-w(i,j,l-1)) 932 continue endif do 94 k=1,l do 94 j=1,mp do 94 i=1,np 94 r(i,j,k)=-r(i,j,k)/d(i,j,k) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) illim = 1 + leftedge if(j3.eq.1) then jllim = 1 + j3*botedge do 95 k=2,l do 95 j=jllim,mp do 95 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j,k )-u(i-1,j,k )+u(i,j-j3,k )-u(i-1,j-j3,k ) 1 +u(i,j,k-1)-u(i-1,j,k-1)+u(i,j-j3,k-1)-u(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i,j,k )-v(i,j-j3,k )+v(i-1,j,k )-v(i-1,j-j3,k ) 2 +v(i,j,k-1)-v(i,j-j3,k-1)+v(i-1,j,k-1)-v(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i,j ,k)-w(i,j ,k-1)+w(i-1,j ,k)-w(i-1,j ,k-1) 3 +w(i,j-j3,k)-w(i,j-j3,k-1)+w(i-1,j-j3,k)-w(i-1,j-j3,k-1) ) rhoav=.125*( d(i,j,k-1)+d(i-1,j,k-1)+d(i-1,j-j3,k-1)+d(i,j-j3,k-1) 1 +d(i,j,k) +d(i-1,j,k) +d(i-1,j-j3,k) +d(i,j-j3,k) ) 95 r(i,j,k)=-r(i,j,k)/rhoav else do 96 k=2,l do 96 i=illim,np r(i,1,k)=dxi2*( u(i,1,k)-u(i-1,1,k)+u(i,1,k-1)-u(i-1,1,k-1)) 3 +dzi2*( w(i,1,k)-w(i,1,k-1)+w(i-1,1,k)-w(i-1,1,k-1)) rhoav=.25*( d(i,1,k-1)+d(i-1,1,k-1)+d(i,1,k)+d(i-1,1,k)) 96 r(i,1,k)=-r(i,1,k)/rhoav endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif #if (TIMEPLT == 1) call ttend(21) #endif return end #endif /* ANALIZE == 0 */ subroutine filtprf(a,n3,ifl1,ifl2) dimension a(n3) include 'param.nml' include 'msg.inc' dimension sz(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(66) #endif if (ifl1.eq.1) then do k=2,l-1 sz(k)=0.25*(a(k+1)+2.*a(k)+a(k-1)) end do sz(1)=a(1) sz(l)=a(l) do k=1,l a(k)=sz(k) end do end if if (ifl2.eq.1) then do k=3,l-2 sz(k)=0.25*(a(k+2)+2.*a(k)+a(k-2)) end do sz(1)=a(1) sz(2)=a(2) sz(l)=a(l) sz(l-1)=a(l-1) do k=1,l a(k)=sz(k) end do end if #if (TIMEPLT == 1) call ttend(66) #endif return end subroutine noise(f1,f2,f3,iflg) include 'param.nml' include 'msg.inc' dimension f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l) dimension f1temp(np, mp, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common /hstst/ theq(1-ih:np+ih,1-ih:mp+ih,l), . dfhs(1-ih:np+ih,1-ih:mp+ih,l), . hskf,hska,hsks, . qveq(1-ih:nmsp+ih,1-ih:mmsp+ih,lms) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #include "msg.lnk" c randomf1(x,kk)=(x) c randomf2(x,kk)=(x-0.5) c randomf3(x,kk)=(x-0.5)*amax1(0.,1.-(kk-1)*dz/500.) #if (TIMEPLT == 1) call ttbeg(67) #endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c inodes=1 ! different seeding on different processor inodes=1 ! noise equivalent to single processor run CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C Numerical Recipes in Fortran - Quick and Dirty Generators p.274-275 C im ia ic overflow C 86436 1093 18254 2^27 C 117128 1277 24749 2^28 C 145800 3661 30809 2^29 C 139968 3877 29573 2^30 C 134456 8121 28411 2^31 C 233280 9301 49297 2^32 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c im=117128 c ia=1277 c ic=24749 im=86436 ia=1093 ic=18254 iran=mype+1 ! mype is a processor geometry parameter #if (PARALLEL == 0) #if (POLES == 0) do k=1,l-ibcz do j=1,mp-ibcy do i=1,np-ibcz #else do k=1,l do j=1,mp do i=1,np #endif iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j,k)=(randx-0.5) iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f3(i,j,k)=randx enddo enddo enddo #else if (inodes.eq.1) then ! different seeding on multiprocessor run iran=mype+1 ! different iran on each processor #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*topedge #else iulim=np julim=mp #endif kulim= l-ibcz do k=1,kulim do j=1,julim do i=1,iulim iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j,k)=(randx-0.5) C *dfhs(i,j,k)*cosa(i,j)**2 iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f3(i,j,k)=randx enddo enddo enddo else ! noise equivalent to single processor run iran = 1 ! iran equivalent to single processor seeding do k=1,l-ibcz #if (POLES == 0) do jam=1,m-ibcy ! total domain position in y do ian=1,n-ibcx ! total domain position in x #else do jam=1,m do ian=1,n #endif i=ian-(npos-1)*np ! local processor position in x j=jam-(mpos-1)*mp ! local processor position in y iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) c . f1(i,j,k)=(randx-0.5) c . *dfhs(i,j,k)*cosa(i,j)**2 . f1(i,j,k)=(randx-0.5) !mod 20111129 c . f1(i,j,k)=(randx-0.5)*cosa(i,j)**4 iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f3(i,j,k)=randx enddo end do end do endif #endif if(ibcz.eq.1) then do j=1,mp do i=1,np f1(i,j,l)=f1(i,j,1) f2(i,j,l)=f2(i,j,1) f3(i,j,l)=f3(i,j,1) enddo end do endif isym=0 if (isym.eq.1) then c impose symmetric noise w.r.t. equator nmlp = np*mp*l iprocsym = (nprocy - mpos)*nprocx + npos - 1 nprocyh = nprocy/2 if (mpos.gt.nprocyh) then do k=1,l do j=1,mp do i=1,np f1temp(i,j,k)=f1(i,j,k) enddo enddo enddo call MPI_Send(f1temp,nmlp,DC_TYPE,iprocsym,99, & MPI_COMM_EULAG,ierr) else call MPI_Recv(f1temp,nmlp,DC_TYPE,iprocsym,99, & MPI_COMM_EULAG,status,ierr) do k=1,l do j=1,mp do i=1,np if (iflg.eq.0) then f1(i,j,k)=f1temp(i,mp-j+1,k) else c impose antisymmetric noise w.r.t. equator for b f1(i,j,k)=-f1temp(i,mp-j+1,k) endif enddo enddo enddo endif call mybarrier() endif !isym #if (POLES == 0) if(ibcx.eq.1) then call updatelr(f1,np,mp,l,np,mp,1) call updatelr(f2,np,mp,l,np,mp,1) call updatelr(f3,np,mp,l,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp f1(np,j,k)=f1(np+1,j,k) f2(np,j,k)=f2(np+1,j,k) f3(np,j,k)=f3(np+1,j,k) enddo enddo end if end if if(ibcy.eq.1) then call updatebt(f1,np,mp,l,np,mp,1) call updatebt(f2,np,mp,l,np,mp,1) call updatebt(f3,np,mp,l,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np f1(i,mp,k)=f1(i,mp+1,k) f2(i,mp,k)=f2(i,mp+1,k) f3(i,mp,k)=f3(i,mp+1,k) enddo end do end if end if #else call update2(f1,np,mp,l,np,mp,1) call update2(f2,np,mp,l,np,mp,1) call update2(f3,np,mp,l,np,mp,1) #endif #if (TIMEPLT == 1) call ttend(67) #endif return end subroutine nois2(f1,f2,iseed) include 'param.nml' include 'msg.inc' dimension f1(1-ih:np+ih, 1-ih:mp+ih), . f2(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c randomf1(x,kk)=(x) c randomf2(x,kk)=(x-0.5) c randomf3(x,kk)=(x-0.5)*amax1(0.,1.-(kk-1)*dz/500.) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC inodes=1 ! different seeding on different processor c inodes=0 ! noise equivalent to single processor run CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C Numerical Recipes in Fortran - Quick and Dirty Generators p.274-275 C im ia ic overflow C 86436 1093 18254 2^27 C 117128 1277 24749 2^28 C 145800 3661 30809 2^29 C 139968 3877 29573 2^30 C 134456 8121 28411 2^31 C 233280 9301 49297 2^32 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC im=86436 ia=1093*iseed ic=18254 iran=mype+1 ! mype is a processor geometry parameter #if (PARALLEL == 0) #if (POLES == 0) do j=1,mp-ibcy do i=1,np-ibcx #else do j=1,mp do i=1,np #endif iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j)=(randx-0.5) enddo enddo #else if (inodes.eq.1) then ! different seeding on multiprocessor run iran=mype+1 ! different iran on each processor #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*topedge #else iulim=np julim=mp #endif do j=1,julim do i=1,iulim iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j)=(randx-0.5) enddo enddo else ! noise equivalent to single processor run iran = 1 ! iran equivalent to single processor seeding #if (POLES == 0) do jam=1,m-ibcy ! total domain position in y do ian=1,n-ibcx ! total domain position in x #else do jam=1,m do ian=1,n #endif i=ian-(npos-1)*np ! local processor position in x j=jam-(mpos-1)*mp ! local processor position in y iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f1(i,j)=(randx-0.5) enddo end do endif #endif iflt=1 if(iflt.eq.1) then customize: filter noise call updatelr(f1,np,mp,1,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy #else illim = 1 iulim = np #endif do j=1,mp do i=illim,iulim f2(i,j)=0.25*(f1(i+1,j)+2.*f1(i,j)+f1(i-1,j)) enddo #if (POLES == 0) if (leftedge.eq.1) then f2(1,j)=ibcx*0.25*(f1(2,j)+2.*f1(1,j)+f1(-1,j))+ibox*f1(1,j) end if if (rightedge.eq.1) then temp=0.25*(f1(np+2,j)+2.*f1(np+1,j)+f1(np-1,j)) f2(np,j)=ibcx*temp+ibox*f1(np,j) end if #endif do i=1,np f1(i,j)=f2(i,j) f2(i,j)=0. enddo enddo endif #if (POLES == 0) if(ibcx.eq.1) then call updatelr(f1,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp f1(np,j)=f1(np+1,j) enddo end if end if if(ibcy.eq.1) then call updatebt(f1,np,mp,1,np,mp,iupy) if (topedge.eq.1) then do i=1,np f1(i,mp)=f1(i,mp+1) enddo end if end if #endif call update(f1,np,mp,1,np,mp,1) if(iflt.eq.1) call filstr2(f1) return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c stress code c C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine rical(u,v,w,th,qv,qc,ismoth) C-grid Richardson number include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 12) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 5) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common /stress2/ d11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d22(1-ih:np+ih, 1-ih:mp+ih+1, l), * d23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . d13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * dv(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/stresd/ diagstr(8),ivis,irid,itstr common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm cdel real qwk,qwkm1 real dqv,qva,dThd,N2unsat,ee,Tk,Tkm1,Ta,dqw, 1 rgam,c1,c2,c3,N2sat c #if (TIMEPLT == 1) call ttbeg(49) #endif compute some local constants hdxi=0.5*dxi hdyi=0.5*dyi hdzi=0.5*dzi if(j3.eq.1) dii=3. if(j3.eq.0) dii=2. c initialize output variables call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) DO K=1,L do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+the(i,j,k) ri(i,j,k)=0. stab(i,j,k)=0. defsq(i,j,k)=0. d33(i,j,k)=0. end do end do do j=1,mp+1 do i=1,np+1 d11(i,j,k)=0. d12(i,j,k)=0. enddo cdel enddo cdel do j=1,mp+1 do i=1,np d22(i,j,k)=0. enddo enddo ENDDO cdel nm1L1 = n*(m+1)*(L+1) DO K=1,L+1 do j=1,mp+1 do i=1,np d23(i,j,k)=0. enddo enddo do j=1,mp do i=1,np+1 d13(i,j,k)=0. enddo enddo ENDDO c surface fluxes --------> do j=1,mp do i=1,np hx=-s13(i,j)/gi(i,j)*zb hy=-s23(i,j)/gi(i,j)*zb vtng=sqrt( (u(i,j,1)+hx*w(i,j,1))**2/(1.+hx**2) . +(v(i,j,1)+hy*w(i,j,1))**2/(1.+hy**2) ) tauw(i,j)=cdrg*vtng*rho(i,j,1) enddo enddo compute velocity z-derivatives. note du/dz is in d13, dv/dz is in d23 do k=2,l do j=1,mp do i=1,np d13(i,j,k)=dzi*(u(i,j,k)-u(i,j,k-1)) d23(i,j,k)=dzi*(v(i,j,k)-v(i,j,k-1)) end do end do end do if(ibcz.eq.0) then Constraints for "free-slip" boundaries: c in 2D: [ d13*(1.-hx**2)=(d11-d33)*hx ] c in 3D: (1-hx**2)*d13- hx*hy*d23=(d11-d33)*hx+d12*hy c in 3D: -hx*hy*d13+(1-hy**2)*d23=(d22-d33)*hy+d12*hx c where di3 denotes stress' elements; these conditions lead c to auxiliary conditions on dui/dz denoted by di3 temporarily c note that top boundary is assumed to be flat #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge #else jllim = 1 julim = mp #endif do j=jllim,julim #if (POLES == 0) if (topedge.eq.1 .and. j.eq.mp) then if (ibcy.eq.1) then jp1 = mp + 2 else jp1 = mp end if else jp1 = j + j3 end if if (botedge.eq.1 .and. j.eq.1) then if (ibcy.eq.1) then jm1 = -1 else jm1 = 1 end if else jm1 = j - j3 end if cvec jp1=(j+j3-j/m*(m-1))*ibcy+(1-ibcy)*min0(j+j3,m) cvec jm1=(j-j3+(m-j)/(m-j3)*(m-j3))*ibcy+(1-ibcy)*max0(j-j3,1) dyil=hdyi if ((ibcy.eq.0) .and. (j.eq.1 .and. botedge.eq.1)) dyil=dyi if ((ibcy.eq.0) .and. (j.eq.mp .and. topedge.eq.1)) dyil=dyi cvec if((ibcy.eq.0) .and. (j.eq.1.or.j.eq.m) ) dyil=dyi #else jp1 = j + j3 jm1 = j - j3 dyil=hdyi #endif do i=1,np #if (POLES == 0) if (rightedge.eq.1 .and. i.eq.np) then if (ibcx.eq.1) then ip1 = np + 2 else ip1 = np end if else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then if (ibcx.eq.1) then im1 = -1 else im1 = 1 end if else im1 = i - 1 end if cvec ip1=(i+1-i/n*(n-1))*ibcx+(1-ibcx)*min0(i+1,n) cvec im1=(i-1+(n-i)/(n-1)*(n-1))*ibcx+(1-ibcx)*max0(i-1,1) dxil=hdxi if ((ibcx.eq.0) .and. (i.eq.1 .and. leftedge.eq.1)) dxil=dxi if ((ibcx.eq.0) .and. (i.eq.np .and. rightedge.eq.1)) dxil=dxi cvec if((ibcx.eq.0) .and. (i.eq.1.or.i.eq.n) ) dxil=dxi #else ip1 = i + 1 im1 = i - 1 dxil=hdxi #endif hx=-s13(i,j)/gi(i,j)*zb hy=-s23(i,j)/gi(i,j)*zb btt=1.+hx**2+hy**2 gmm=1-hx**2 dlt=1-hy**2 cc=1./gi(i,j)/btt d13(i,j,1)=cc*(-gmm*(w(ip1,j,1)-w(im1,j,1))*dxil . -hx/cc*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3))*dzi . +( 2.*hx*(u(ip1,j,1)-u(im1,j,1))*dxil . + hy*( (u(i,jp1,1)-u(i,jm1,1))*dyil . +(v(ip1,j,1)-v(im1,j,1))*dxil ) . +hx*hy*(w(i,jp1,1)-w(i,jm1,1))*dyil )) .+tauw(i,j)*(u(i,j,1)+hx*w(i,j,1))/sqrt(btt) d23(i,j,1)=cc*(-dlt*(w(i,jp1,1)-w(i,jm1,1))*dyil . -hy/cc*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3))*dzi . +( 2.*hy*(v(i,jp1,1)-v(i,jm1,1))*dyil . + hx*( (u(i,jp1,1)-u(i,jm1,1))*dyil . +(v(ip1,j,1)-v(im1,j,1))*dxil ) . +hx*hy*(w(ip1,j,1)-w(im1,j,1))*dxil )) .+tauw(i,j)*(v(i,j,1)+hy*w(i,j,1))/sqrt(btt) d13(i,j,1)=2.*d13(i,j,1)-d13(i,j,2) d23(i,j,1)=2.*d23(i,j,1)-d23(i,j,2) d13(i,j,l+1)=-d13(i,j,l) d23(i,j,l+1)=-d23(i,j,l) enddo enddo close free-slip constraint else do j=1,mp do i=1,np d13(i,j,1)=d13(i,j,L) d23(i,j,1)=d23(i,j,L) d13(i,j,L+1)=d13(i,j,2) d23(i,j,L+1)=d23(i,j,2) end do end do endif compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar do k=2,l do j=1,mp do i=1,np dv(i,j,k)=-dzi*(rho(i,j,k)-rho(i,j,k-1))*gi(i,j)* * (w(i,j,k)+w(i,j,k-1))/(rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np dv(i,j,1 )=(1-ibcz)*(2.*dv(i,j,2)-dv(i,j, 3 ))+ibcz*dv(i,j,L) dv(i,j,L+1)=(1-ibcz)*(2.*dv(i,j,L)-dv(i,j,L-1))+ibcz*dv(i,j,2) end do end do c c save off divergence temporarily in ri do k=1,L do j=1,mp do i=1,np ri(i,j,k)=dv(i,j,k) end do end do end do c compute d11 at (i +- 1/2, j, k) if (rightedge.eq.0 .and. topedge.eq.0) then call update2(dv,np,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update2(dv,np+1,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update2(dv,np,mp+1,l+1,np+1,mp+1,1) else call update2(dv,np+1,mp+1,l+1,np+1,mp+1,1) end if if (rightedge.eq.0) then call update(d13,np,mp,l+1,np+1,mp,1) else call update(d13,np+1,mp,l+1,np+1,mp,1) end if #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,L do j=1,mp do i=illim,iulim g13=gmul(k)*0.5*(s13(i-1,j)+s13(i,j)) uza=0.25*(d13(i-1,j,k)+d13(i,j,k)+ 1 d13(i-1,j,k+1)+d13(i,j,k+1)) dva=0.25*(dv(i-1,j,k)+dv(i,j,k)+dv(i-1,j,k+1)+dv(i,j,k+1)) uxa=dxi*(u(i,j,k)-u(i-1,j,k)) d11(i,j,k) = 2.*( uxa + g13*uza - dva/dii ) end do end do end do #if (POLES == 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d11,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(d11,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l d11(1,j,k) =(ibcx-1)*d11(2,j,k) + ibcx*d11(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l d11(np+1,j,k) =(ibcx-1)*d11(np,j,k) + ibcx*d11(np+3,j,k) end do end do end if #endif compute contribution of d11 to Def**2 if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d11,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1,1) else call updatelr(d11,np+1,mp+1,l,np+1,mp+1,1) end if do k=1,L do j=1,mp do i=1,np d11a = 0.5*(d11(i,j,k)**2 + d11(i+1,j,k)**2 ) d11b =amax1(d11(i,j,k)**2 , d11(i+1,j,k)**2 ) d11a=.5*(d11a+d11b) defsq(i,j,k) = 0.5*d11a end do end do end do compute d33 at (i, j, k +- 1/2) do j=1,mp do i=1,np do k=2,L wza = dzi*(w(i,j,k)-w(i,j,k-1)) d33(i,j,k) = 2.*( gi(i,j)*wza - dv(i,j,k)/dii ) end do end do end do create boundary conditions at k=1 if(ibcz.eq.0) then do j=1,mp do i=1,np wza = dzi*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3)) d33(i,j,1) = 2.*( gi(i,j)*wza - dv(i,j,1)/dii ) end do end do else do j=1,mp do i=1,np d33(i,j,1) = d33(i,j,L) end do end do endif compute contribution of d33 to def**2 if(ibcz.eq.0) then do j=1,mp do i=1,np do k=1,L-1 d33a = 0.5 *(d33(i,j,k)**2 + d33(i,j,k+1)**2 ) d33b = amax1(d33(i,j,k)**2 , d33(i,j,k+1)**2 ) d33a=.5*(d33a+d33b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d33a end do corporate b.c. by extrapolation to obtain d33 at k=L+1 d33Lp1 = 2.*d33(i,j,L)-d33(i,j,L-1) d33a = 0.5 *(d33(i,j,L)**2 + d33Lp1**2 ) d33b = amax1(d33(i,j,L)**2 , d33Lp1**2 ) d33a=.5*(d33a+d33b) defsq(i,j,L) = defsq(i,j,L) + 0.5*d33a end do end do else do j=1,mp do i=1,np do k=1,l-1 d33a = 0.5 *(d33(i,j,k)**2 + d33(i,j,k+1)**2 ) d33b = amax1(d33(i,j,k)**2 , d33(i,j,k+1)**2 ) d33a=.5*(d33a+d33b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d33a end do corporate b.c. by extrapolation to obtain d33 at k=L+1 defsq(i,j,l) = defsq(i,j,1) end do end do endif c add in d22, d12, d23 if 3D problem if (topedge.eq.0) then call update(d23,np,mp,l+1,np,mp+1,1) else call update(d23,np,mp+1,l+1,np,mp+1,1) end if if (j3.eq.1) then compute d22 at (i, j +- 1/2, k) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp #endif do k=1,L do j=jllim,julim do i=1,np g23=0.5*gmul(k)*(s23(i,j-j3)+s23(i,j)) vza=0.25*(d23(i,j-j3,k )+d23(i,j,k )+ . d23(i,j-j3,k+1)+d23(i,j,k+1) ) dva=0.25*(dv(i,j-j3,k )+dv(i,j,k )+ . dv(i,j-j3,k+1)+dv(i,j,k+1) ) vya=dyi*(v(i,j,k)-v(i,j-j3,k)) d22(i,j,k) = 2.*( vya + g23*vza - j3*dva/dii ) end do end do end do #if (POLES == 0) if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1,iupy) else call updatebt(d22,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l do i=1,np d22(i,1,k) = (ibcy-1)*d22(i,2,k) + ibcy*d22(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np d22(i,mp+1,k) = (ibcy-1)*d22(i,mp,k) + . ibcy*d22(i,mp+3,k) end do end do end if #endif compute contribution of d22 to def**2 if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1,1) else call updatebt(d22,np,mp+1,l,np,mp+1,1) end if do k=1,L do j=1,mp do i=1,np d22a = 0.5 *(d22(i,j,k)**2 + d22(i,j+1,k)**2 ) d22b = amax1(d22(i,j,k)**2 , d22(i,j+1,k)**2 ) d22a=.5*(d22a+d22b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d22a end do end do end do endif compute d12 at (i +- 1/2, j+- 1/2, k) jllim = 1 + j3*botedge julim = mp illim = 1 + leftedge iulim = np do k=1,L do j=jllim,julim do i=illim,iulim g13=gmul(k)*0.25*( s13(i-1,j-j3) + s13(i,j-j3) . + s13(i-1,j ) + s13(i,j ) ) g23=gmul(k)*0.25*( s23(i-1,j-j3) + s23(i,j-j3) . + s23(i-1,j ) + s23(i,j ) ) uya=hdyi*((u(i-1,j,k)-u(i-1,j-j3,k))+(u(i,j,k)-u(i,j-j3,k))) vxa=hdxi*((v(i,j-j3,k)-v(i-1,j-j3,k))+(v(i,j,k)-v(i-1,j,k))) uza=0.125*( d13(i-1,j-j3,k )+d13(i,j-j3,k ) . + d13(i-1,j ,k )+d13(i,j ,k ) . + d13(i-1,j-j3,k+1)+d13(i,j-j3,k+1) . + d13(i-1,j ,k+1)+d13(i,j ,k+1) ) vza=0.125*( d23(i-1,j-j3,k )+d23(i,j-j3,k ) . + d23(i-1,j ,k )+d23(i,j ,k ) . + d23(i-1,j-j3,k+1)+d23(i,j-j3,k+1) . + d23(i-1,j ,k+1)+d23(i,j ,k+1) ) d12(i,j,k) = uya + g23*uza + vxa + g13*vza end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 (for j=1+j3,m) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d12,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d12,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d12,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(d12,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=jllim,julim do k=1,l d12( 1,j,k)=(ibcx-1)*d12(2,j,k)+ibcx*d12( -1,j,k) end do end do end if if (rightedge.eq.1) then do j=jllim,julim do k=1,l d12(np+1,j,k)=(ibcx-1)*d12(np,j,k)+ibcx*d12(np+3,j,k) end do end do end if create boundary conditions at j=1 and m+1 (for i=1,n+1) if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(d12,np,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(d12,np+1,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(d12,np,mp+1,l,np+1,mp+1,iupy) else call updatebt(d12,np+1,mp+1,l,np+1,mp+1,iupy) end if illim = 1 iulim = np + 1*rightedge if (botedge.eq.1) then do k=1,l do i=illim,iulim d12(i,1 ,k)=(ibcy-1)*d12(i,2 ,k)+ibcy*d12(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=illim,iulim d12(i,mp+1,k)=(ibcy-1)*d12(i,mp,k)+ibcy*d12(i,mp+3,k) end do end do end if #endif compute contribution of d12 to def**2 if (rightedge.eq.0 .and. topedge.eq.0) then call update(d12,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(d12,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(d12,np,mp+1,l,np+1,mp+1,1) else call update(d12,np+1,mp+1,l,np+1,mp+1,1) end if do k=1,l do j=1,mp do i=1,np d12a = 0.25*(d12(i,j,k)**2 + d12(i+1,j,k)**2 . + d12(i,j+1,k)**2 + d12(i+1,j+1,k)**2 ) d12b = amax1(d12(i,j,k)**2 , d12(i+1,j,k)**2 . , d12(i,j+1,k)**2 , d12(i+1,j+1,k)**2 ) d12a=.5*(d12a+d12b) defsq(i,j,k) = defsq(i,j,k) + d12a end do end do end do compute d23 at (i, j +- 1/2, k +- 1/2) c note d23 is logically equivalenced to vz so j loop must descend jllim = 1 + j3*botedge julim = mp do k=2,l do j=julim,jllim,-1 do i=1,np gii=0.5*(gi(i,j-j3)+gi(i,j)) g23=0.25*(gmul(k-1)+gmul(k))*(s23(i,j-j3)+s23(i,j)) wya=hdyi*((w(i,j,k-1)-w(i,j-1,k-1))+(w(i,j,k)-w(i,j-1,k))) vza=0.5*(d23(i,j-j3,k)+d23(i,j,k)) wza=hdzi*((w(i,j-j3,k)-w(i,j-j3,k-1))+ 1 (w(i,j ,k)-w(i,j ,k-1))) d23(i,j,k) = ( gii*vza + wya + g23*wza ) end do end do end do create boundary conditions at k=1 and L+1 (for j=2,m) if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,1) else call updatebt(d23,np,mp+1,l+1,np,mp+1,1) end if if(ibcz.eq.0) then do j=julim,jllim,-1 do i=1,np gii=0.5*(gi(i,j-j3)+gi(i,j)) g23=.25*(3.*gmul(1)-gmul(2))*(s23(i,j-j3)+s23(i,j)) wya=hdyi*(3.*(w(i,j,1)-w(i,j-j3,1))-(w(i,j,2)-w(i,j-j3,2))) vza=0.5*(d23(i,j-j3,1)+d23(i,j,1)) wza=(3.*w(i,j ,2)-2.*w(i,j ,1)-w(i,j ,3))*hdzi 1 +(3.*w(i,j-j3,2)-2.*w(i,j-j3,1)-w(i,j-j3,3))*hdzi d23(i,j,1) = ( gii*vza+ wya+ g23*wza) d23(i,j,L+1) = 0.5*(d23(i,j-j3,L+1)+d23(i,j,L+1)) end do end do else do j=julim,jllim,-1 do i=1,np d23(i,j, 1 ) = d23(i,j,L) d23(i,j,L+1) = d23(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at j=1 and m+1 (for k=1,L+1) if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,iupy) else call updatebt(d23,np,mp+1,l+1,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,np d23(i,1 ,k)=(ibcy-1)*d23(i,2 ,k)+ibcy*d23(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l+1 do i=1,np d23(i,mp+1,k)=(ibcy-1)*d23(i,mp,k)+ibcy*d23(i,mp+3,k) end do end do end if #endif compute contribution of d23 to def**2 if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,1) else call updatebt(d23,np,mp+1,l+1,np,mp+1,1) end if do k=1,l do j=1,mp do i=1,np d23a = 0.25*(d23(i,j,k )**2 + d23(i,j+1,k )**2 . + d23(i,j,k+1)**2 + d23(i,j+1,k+1)**2 ) d23b = amax1(d23(i,j,k )**2 , d23(i,j+1,k )**2 . , d23(i,j,k+1)**2 , d23(i,j+1,k+1)**2 ) d23a=.5*(d23a+d23b) defsq(i,j,k) = defsq(i,j,k) + d23a end do end do end do compute d13 at (i +- 1/2,j,k +- 1/2) c note d13 is logically equivalenced to uz so i loop must descend illim = 1 + leftedge iulim = np do k=2,l do j=1,mp do i=iulim,illim,-1 gii=0.5*(gi(i-1,j)+gi(i,j)) g13=0.25*(gmul(k-1)+gmul(k))*(s13(i-1,j)+s13(i,j)) wxa=hdxi*((w(i,j,k-1)-w(i-1,j,k-1))+(w(i,j,k)-w(i-1,j,k))) uza=0.5*(d13(i-1,j,k)+d13(i,j,k)) wza=hdzi*((w(i-1,j,k)-w(i-1,j,k-1))+(w(i,j,k)-w(i,j,k-1))) d13(i,j,k) = gii*uza + wxa + g13*wza end do end do end do create boundary conditions at k=1 and L+1 (for i=2,n) if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,1) else call updatelr(d13,np+1,mp,l+1,np+1,mp,1) end if if(ibcz.eq.0) then do j=1,mp do i=iulim,illim,-1 gii=0.5*(gi(i-1,j)+gi(i,j)) g13=.25*(3.*gmul(1)-gmul(2))*(s13(i-1,j)+s13(i,j)) wxa=hdxi*(3.*(w(i,j,1)-w(i-1,j,1))-(w(i,j,2)-w(i-1,j,2))) uza=0.5*(d13(i-1,j,1)+d13(i,j,1)) wza=(3.*w(i ,j,2)-2.*w(i ,j,1)-w(i ,j,3))*hdzi 1 +(3.*w(i-1,j,2)-2.*w(i-1,j,1)-w(i-1,j,3))*hdzi d13(i,j,1) = ( gii*uza+ wxa+ g13*wza) d13(i,j,L+1) = 0.5*(d13(i-1,j,L+1)+d13(i,j,L+1)) end do end do else do j=1,mp do i=iulim,illim,-1 d13(i,j, 1 ) = d13(i,j,L) d13(i,j,L+1) = d13(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at i=1 and n+1 (for k=1,l+1) if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,iupx) else call updatelr(d13,np+1,mp,l+1,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l+1 d13( 1,j,k)=(ibcx-1)*d13(2 ,j,k)+ibcx*d13(-1 ,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l+1 d13(np+1,j,k)=(ibcx-1)*d13(np,j,k)+ibcx*d13(np+3,j,k) end do end do end if #endif compute contribution of d13 to def**2 if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,1) else call updatelr(d13,np+1,mp,l+1,np+1,mp,1) end if do k=1,l do j=1,mp do i=1,np d13a = 0.25*(d13(i,j,k )**2 + d13(i+1,j,k )**2 . + d13(i,j,k+1)**2 + d13(i+1,j,k+1)**2 ) d13b = amax1(d13(i,j,k )**2 , d13(i+1,j,k )**2 . , d13(i,j,k+1)**2 , d13(i+1,j,k+1)**2 ) d13a=.5*(d13a+d13b) defsq(i,j,k) = defsq(i,j,k) + d13a end do end do end do compute stability on A grid and store temporarily in dv if (moist.eq.1) then !moist case eps = Rg/Rv ! eps=Rd/Rv=0.622 ee = (1.-eps)/eps ! =0.61 c1=hlat/rg ! c1=L/Rd c2=hlat/cp ! c2=L/cp c3=eps*c2*c1 ! c3=eps*L**2/(cp*Rd) do k=2,L do j=1,mp do i=1,np compute stability for unsaturated portions as N**2 = dln(thetav)/dz c (e.g., Emanuel, Atmospheric Convection (6.1.7)) where thetav is the c virtual potential temp, thetav = thetad*(1+ee*qv), where c ee=(1-eps)/eps, eps=Rd/Rv c N**2 = dln(thetad)/dz + (ee/(1+ee*qv))*dqv/dz dqv = (qv(i,j,k)-qv(i,j,k-1)) qva = 0.5*(qv(i,j,k)+qv(i,j,k-1)) dThd = (th(i,j,k) - th(i,j,k-1))/ . (0.5*(th0(i,j,k) + th0(i,j,k-1))) N2unsat = dThd + (ee/(1.+ee*qva))*dqv compute stability for saturated portions according to Durran and Klemp, c JAS 1982, p. 2152, eq(36). The local temperature Ta is approximated c by T/Te = theta/thetae Tk = tme(i,j,k)*(th(i,j,k)/the(i,j,k)) Tkm1= tme(i,j,k-1)*(th(i,j,k-1)/the(i,j,k-1)) Ta = 0.5*(Tk + Tkm1) dqw = (qv(i,j,k)+qc(i,j,k)) - (qv(i,j,k-1)+qc(i,j,k-1)) rgam = (1.+c1*qva/Ta)/(1.+c3*qva/(Ta*Ta)) N2sat = rgam*(dThd + c2*dqv/Ta) - dqw dv(i,j,k)=g*dzi*gi(i,j)*cvmgmxx(N2unsat,N2sat, . 0.5*(qc(i,j,k)+qc(i,j,k-1))-1.e-6) end do end do end do c else ! dry case do k=2,L do j=1,mp do i=1,np dv(i,j,k)=( ( th(i,j,k)- th(i,j,k-1))/ . ((th0(i,j,k)+th0(i,j,k-1))*0.5) )* . g*dzi*gi(i,j) end do end do end do endif c do j=1,mp do i=1,np dv(i,j, 1 )=(1-ibcz)*dv(i,j,2)+ibcz*dv(i,j,L) dv(i,j,L+1)=(1-ibcz)*dv(i,j,L)+ibcz*dv(i,j,2) end do end do c compute stability at A-grid points do j=1,mp do i=1,np do k=1,L stab(i,j,k)=0.5*(dv(i,j,k)+dv(i,j,k+1)) end do end do end do c c copy back divergence temporarily stored in ri for output #if (HP > 0) C do k=1,l ! This loops C do j=1,mp ! Dont work with C do i=1,np ! +O3,+O4 optimalization on HP do j=1,mp do i=1,np do k=1,l #else do k=1,L do j=1,mp do i=1,np #endif dv(i,j,k)=ri(i,j,k) end do end do end do do j=1,mp do i=1,np dv(i,j,L+1)=(1-ibcz)*(2.*dv(i,j,L)-dv(i,j,L-1)) . +ibcz*dv(i,j,2) end do end do c c smooth resultant defsq field if(ismoth.ge.2) then call filstr(defsq) endif c do k=1,l do j=1,mp do i=1,np ri(i,j,k) = stab(i,j,k)/amax1(defsq(i,j,k),1.0e-15) th(i,j,k)=th(i,j,k)-the(i,j,k) enddo enddo enddo c c smooth resultant Ri field if(ismoth.ge.1) then call filstr(ri) ! ri updated inside filstr else call update(ri,np,mp,l,np,mp,1) ! update ri endif #if (TIMEPLT == 1) call ttend(49) #endif return end subroutine filstr(a) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) dimension sx(np),sy(mp),sz(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(29) #endif call updatelr(a,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz #else illim = 1 iulim = np iboz=1-ibcz #endif do k=1,l do j=1,mp do i=illim,iulim sx(i)=0.25*(a(i+1,j,k)+2.*a(i,j,k)+a(i-1,j,k)) enddo #if (POLES == 0) if (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j,k)+2.*a(1,j,k)+a(-1,j,k))+ibox*a(1,j,k) end if if (rightedge.eq.1) then temp=0.25*(a(np+2,j,k)+2.*a(np+1,j,k)+a(np-1,j,k)) sx(np)=ibcx*temp+ibox*a(np,j,k) end if #endif do i=1,np a(i,j,k)=sx(i) enddo enddo enddo if(j3.eq.1) then call updatebt(a,np,mp,l,np,mp,iupy) #if (POLES == 0) jllim=1 + j3*botedge julim=mp - j3*topedge #else jllim=1 julim=mp #endif do k=1,l do i=1,np do j=jllim,julim sy(j)=0.25*(a(i,j+j3,k)+2.*a(i,j,k)+a(i,j-j3,k)) enddo #if (POLES == 0) if (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3,k)+2.*a(i,1,k)+a(i,-j3,k)) . +iboy*a(i,1,k) end if if (topedge.eq.1) then temp=0.25*(a(i,mp+1+j3,k)+2.*a(i,mp+1,k)+a(i,mp-j3,k)) sy(mp)=ibcy*temp+iboy*a(i,mp,k) end if #endif do j=1,mp a(i,j,k)=sy(j) enddo enddo enddo endif do j=1,mp do i=1,np do k=2,l-1 sz(k)=0.25*(a(i,j,k+1)+2.*a(i,j,k)+a(i,j,k-1)) enddo if(ibcz.eq.0) then sz(1)=a(i,j,1) sz(l)=a(i,j,l) else sz(1)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) sz(l)=0.25*(a(i,j,2)+2.*a(i,j,l)+a(i,j,l-1)) endif do k=1,l a(i,j,k)=sz(k) enddo enddo enddo call update(a,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(29) #endif return end subroutine filstr2(a) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih) dimension sx(np),sy(mp) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(29) #endif call updatelr(a,np,mp,1,np,mp,iupx) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy do j=1,mp do i=illim,iulim sx(i)=0.25*(a(i+1,j)+2.*a(i,j)+a(i-1,j)) enddo if (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j)+2.*a(1,j)+a(-1,j))+ibox*a(1,j) end if if (rightedge.eq.1) then temp=0.25*(a(np+2,j)+2.*a(np+1,j)+a(np-1,j)) sx(np)=ibcx*temp+ibox*a(np,j) end if do i=1,np a(i,j)=sx(i) enddo enddo if(j3.eq.1) then call updatebt(a,np,mp,1,np,mp,iupy) jllim=1 + j3*botedge julim=mp - j3*topedge do i=1,np do j=jllim,julim sy(j)=0.25*(a(i,j+j3)+2.*a(i,j)+a(i,j-j3)) enddo if (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3)+2.*a(i,1)+a(i,-j3)) . +iboy*a(i,1) end if if (topedge.eq.1) then temp=0.25*(a(i,mp+1+j3)+2.*a(i,mp+1)+a(i,mp-j3)) sy(mp)=ibcy*temp+iboy*a(i,mp) end if do j=1,mp a(i,j)=sy(j) enddo enddo endif call update(a,np,mp,1,np,mp,1) #if (TIMEPLT == 1) call ttend(29) #endif return end #if (ANALIZE == 0 || ENERGY == 1) #if (SGS == 1) subroutine dissip(u0,v0,w0,th,chm,qv,qc,qr,tke, 1 fx,fy,fz,ft,fchm, 1 qia,qib,fqia,fqib, fqv,fqc,fqr,ftke, 2 fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(40) #endif data ismoo/0/ call rical(u0,v0,w0,th,qv,qc,ismoo) !Ri, def, stability call tkefrc(tke,ftke,pfx,pfy,pfz) !Km & TKE rhs call stress(u0,v0,w0,th,chm,qv,qc,qr,qia,qib, !diffusive rhs 1 fx,fy,fz,foz,u1,v1,w1,oz1, 1 ft,fchm,fqv,fqc,fqr,fqia,fqib,pfx,pfy,pfz) #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine tkefrc(tke,ftke,Prinv,Km,scr1) ! Calculation of eddy viscosity. If itkes=itke=0, Smagorinky's ! approach is adopted. If itke=1, the scheme applies the TKE-equation ! with Schumann's parameterization (see, eg. Sorbjan, 1996,JAS,January) ! The subroutine calls the subroutine lapdf to calculate ! diffusion terms in the TKE equation. ! On input scr1 contains pfz, scr2 contains Ri, scr3 contains N**2, ! scr4 contains divergence; all are destroyed on output !-------------------------------------------------------------------- include 'param.nml' include 'msg.inc' real tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke), 1 Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l) common/blank/ scr2(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l), . Defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr11(1-ih:np+ih, 1-ih:mp+ih, l, 11) parameter(iblank=11*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ d11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d22(1-ih:np+ih, 1-ih:mp+ih+1, l), * d23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . d13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * scr4(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd, * ivis,irid,itstr real kmmx,kmmn,kmav,kmsd common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/sgscnst/ ceps,cL,cm,cs,prndt real cii,cLz,deltl,diva,Diss,E,eps,lambda,Kmij,kmmax,isot,Nsq real globmax,globmin,globsum #if (TIMEPLT == 1) call ttbeg(46) #endif coefficients if(j3.eq.1) then !3D case cii=1./3. deltl=(dx+dy+dz)/3. else !2D case cii=1./2. deltl=sqrt(dx*dz) endif pri=1./prndt ce=2. grkm=(j3*amin1(dx,dy,dz)**2+(1-j3)*amin1(dx,dz)**2)*dti kmmax=-1.e15 eps=1.e-10 Compute the mixing coefficient if(itkes.eq.1) then epkm=1.e-5*grkm do k=1,Lke do j=1,mkep do i=1,nkep cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length cmL=cm*lambda sqrtE=amax1(epkm/cml,tke(i,j,k)) ! E>epsilon E=sqrtE*sqrtE Kmij=cmL*sqrtE ! Km=cm*L*sqrt(E) Nsq=scr3(i,j,k) denomin=E+0.3*deltl*deltl*amax1(0.0,Nsq) prndti=pri*E/denomin ! 1/Prandt cspec prndti=pri ! 1/Prandt SPB=(cmL/2.)*(defsq(i,j,k) - Nsq*prndti) ! S+B diva=0.5*(scr4(i,j,k)+scr4(i,j,k+1)) ! divergence isot=cii*sqrtE*diva ! (1/deltaii)*E*div Diss=ceps*E/(2.*lambda) ! Dissipation ftke(i,j,k)=SPB-isot-Diss ! RHS of tke eqn tke(i,j,k)=sqrtE Prinv(i,j,k)=prndti/pri ! variable part of kmmax=amax1(kmmax,Kmij) ! max of Km CBS Km(i,j,k)=2.*ce*cmL*E ! exact Km(i,j,k)=Kmij ! Deardorff approx enddo enddo enddo if(ibcz.eq.0) then ke=1+itkes do j=1,mkep do i=1,nkep Km(i,j,1)= Km(i,j,ke) tke(i,j,1)= tke(i,j,ke) ftke(i,j,1)= ftke(i,j,ke) Prinv(i,j,1)=Prinv(i,j,ke) enddo enddo endif c compute the flux divergence term, (1/(2sqrt(E))*d/dxj(ce*Km*dE/dxj). c Following Deardorff(BLM,18,495-527,1980), this term is approximated c as d/dxj(ce*Km*dsqrt(E)/dxj). Since ce is a constant we can call LAPDF c to compute d/dxj(Km*dsqrt(E)/dxj), and then multiply by the result by ce. c note scr3 which contained N**2 is destroyed by the output of lapdf. c scr1,scr2,defsq,and scr4 are work arrays and are destroyed. [For exact c call LAPDF to compute d/dxj(2*ce*cm*lambda*E*dsqrt(E)/dxj), where c 2*ce*cm*lambda*E is temproarily in Km, and divide by 2sqrtE afterwards.] do k=1,l do j=1,mp do i=1,np scr3(i,j,k)=1. enddo enddo enddo call lapdf(tke,scr3,Km,scr3,scr1,scr2,defsq,scr4,0) compute RHS in the TKE-equation =2*(Sr+Bu-Ds+Diff) and recompute Km c note the factor 2 comes from the implicit time differencing used in the c main routine do k=1,Lke do j=1,mkep do i=1,nkep CBS cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) CBS lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length CBS cmL=cm*lambda CBS Km(i,j,k)=cmL*tke(i,j,k) ! Km=cm*L*sqrt(E) CBS denomin = 2.*tke(i,j,k) CBS Diff = scr3(i,j,k)/amax1(eps,denomin) Diff = ce*scr3(i,j,k) ftke(i,j,k)=2.*(ftke(i,j,k)+Diff) ! RHS of tke eqn enddo enddo enddo else prndti=pri epkm=1.e-5*grkm do k=1,Lkv do j=1,mkvp do i=1,nkvp cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length SPB=Defsq(i,j,k) - scr3(i,j,k)*prndti ! Def**2-(Kh/Km)*N**2 Prinv(i,j,k)=1. Kmij=(cs*lambda)**2 *sqrt(amax1(SPB,0.0)) ! Smgr-sky's Km Kmij=amax1(Kmij,epkm) Kmij=1.004e-6 Km(i,j,k)=Kmij tke(i,j,k)=Kmij/(cm*lambda) ! sqrt(E)=Km/(c*L) kmmax=amax1(kmmax,Kmij) ! max of Km enddo enddo enddo if(ibcz.eq.0) then kv=1+ivs0 do j=1,mkvp do i=1,nkvp Km(i,j,1)= Km(i,j,kv) tke(i,j,1)=tke(i,j,kv) enddo enddo endif endif compute diagnostics kmmax=globmax(kmmax,1,1,1,1,1,1,1,1,1,1,1,1) dcr1=kmmax*dt*(dxi**2+j3*dyi**2+dzi**2) if(dcr1.gt.0.5) then if(mype.eq.0) print 201,itstr,dcr1 201 format(2x,'it, difcr:',i5,e11.4) stop 'tkefrc cfl' endif if((itstr/noutp)*noutp.eq.itstr) then nml=n*m*l primx=-1.e15 primn= 1.e15 priav=0. kmmx=-1.e15 kmmn= 1.e15 kmav=0. primx = globmax(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) primn = globmin(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) priav = globsum(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmmx = globmax(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmmn = globmin(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmav = globsum(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) priav=priav/float(nml) kmav=kmav/float(nml) prisd=0. kmsd=0. do k=1,l do j=1,mp do i=1,np temp(i,j,k) = (Prinv(i,j,k)-priav)**2 end do end do end do prisd = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) prisd = sqrt(prisd/float(nml)) do k=1,l do j=1,mp do i=1,np temp(i,j,k) = (Km(i,j,k)-kmav)**2 end do end do end do kmsd = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmsd = sqrt(kmsd/float(nml)) endif #if (TIMEPLT == 1) call ttend(46) #endif return end subroutine stress(u,v,w,th,chm,qv,qc,qr,qia,qib,fx,fy,fz,fomeg, . fu,fv,fw,fo,ft,fchm,fqv,fqc,fqr,fqia,fqib,Prinv,Km,scr1) include 'param.nml' include 'msg.inc' real u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:np+ih, 1-ih:mp+ih, l), . fy(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fo(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fomeg(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc) common/blank/ scr3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . f33(1-ih:np+ih, 1-ih:mp+ih, l), . scr12(1-ih:np+ih, 1-ih:mp+ih, l, 12) parameter(iblank=12*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ f11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f22(1-ih:np+ih, 1-ih:mp+ih+1, l), * f23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . f13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * temp(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) c Calculation of the RHS in the prognostic equations, c diffusion terms obtained using km from the TKE-equation (sub."tkefrc") c inputs include Prinv = 1/Pr/pri, Km, f11,...,f23, containing the six c components of the deformation tensor. scr1, scr2, scr3, and temp c are work arrays. c Output: fu,fv,fw,ft,fqv,fqc,fqr. c Note that the subroutine is called only when ivisc=1 and itke=1. c This subroutine calls subroutines lapdf to calculate diffusion terms. common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real den,Kma,tau13,tau23,tau33,tc #if (TIMEPLT == 1) call ttbeg(47) #endif tc=1. compute components of stress tensor tauij c note that terms 2/3 dE/dxi are formally included in pressure terms dP/dxi c and therefore are not present in terms d11, d22, and d33 below: compute G*tau11=d*km*d11 at (i +- 1/2, j, k) call update(Km,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,L do j=1,mp do i=illim,iulim Kma=0.5*(Km(i-1,j,k)+Km(i,j,k)) den=0.5*(rho(i-1,j,k)+rho(i,j,k)) d11=f11(i,j,k) f11(i,j,k)=den*Kma*d11 end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f11,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l f11(1,j,k)=(ibcx-1)*f11(2,j,k) + ibcx*f11(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l f11(np+1,j,k)=(ibcx-1)*f11(np,j,k) + ibcx*f11(np+3,j,k) end do end do end if #endif compute G*tau12=d*km*d12 at (i +- 1/2, j+- 1/2, k) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp illim = 1 + leftedge iulim = np #else jllim = 1 julim = mp + j3*topedge illim = 1 iulim = np #endif do k=1,l do j=jllim,julim do i=illim,iulim Kma=0.25*( Km(i-1,j-j3,k)+Km(i,j-j3,k) . + Km(i-1,j ,k)+Km(i,j ,k) ) den=0.25*(rho(i-1,j-j3,k)+rho(i,j-j3,k) . +rho(i-1,j ,k)+rho(i,j ,k)) d12=f12(i,j,k) f12(i,j,k)=den*Kma*d12 end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 (for j=1+j3,m) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f12,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f12,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f12,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(f12,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=jllim,julim do k=1,l f12( 1,j,k) = (ibcx-1)*f12(2,j,k) + ibcx*f12(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=jllim,julim do k=1,l f12(np+1,j,k) = (ibcx-1)*f12(np,j,k) + . ibcx*f12(np+3,j,k) end do end do end if create boundary conditions at j=1 and m+1 (for i=1,n+1) if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(f12,np,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(f12,np+1,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(f12,np,mp+1,l,np+1,mp+1,iupy) else call updatebt(f12,np+1,mp+1,l,np+1,mp+1,iupy) end if illim = 1 iulim = np + 1*rightedge if (botedge.eq.1) then do k=1,l do i=illim,iulim f12(i,1 ,k)=(ibcy-1)*f12(i,2,k)+ibcy*f12(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=illim,iulim f12(i,mp+1,k)=(ibcy-1)*f12(i,mp,k)+ibcy*f12(i,mp+3,k) end do end do end if #endif compute G*tau13=d*km*d13 at (i +- 1/2, j, k +- 1/2) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=2,l do j=1,mp do i=illim,iulim den=0.25*(rho(i-1,j,k-1)+rho(i,j,k-1) . +rho(i-1,j,k )+rho(i,j,k )) Kma=0.25*(Km(i-1,j,k-1)+Km(i,j,k-1) . +Km(i-1,j,k )+Km(i,j,k )) d13 = f13(i,j,k) f13(i,j,k) = den*Kma*d13 end do end do end do create boundary conditions at k=1 and l+1 (for i=1,n+1) if(ibcz.eq.0) then do j=1,mp do i=illim,iulim den=0.25*(3.*(rho(i-1,j,2)+rho(i,j,2)) . -(rho(i-1,j,1)+rho(i,j,1)) ) Kma=0.25*(Km(i-1,j,1)+Km(i,j,1)+Km(i-1,j,2)+Km(i,j,2)) f13(i,j,1) = den*Kma*f13(i,j,1) den=0.25*(3.*(rho(i-1,j,L )+rho(i,j,L )) . -(rho(i-1,j,L-1)+rho(i,j,L-1)) ) Kma=0.25*(Km(i-1,j,L)+Km(i,j,L)+Km(i-1,j,L-1)+Km(i,j,L-1)) f13(i,j,L+1) = den*Kma*f13(i,j,L+1) end do end do else do j=1,mp do i=illim,iulim f13(i,j, 1 ) = f13(i,j,L) f13(i,j,L+1) = f13(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions for i=1 and n+1 (for k=2,l) if (rightedge.eq.0) then call updatelr(f13,np,mp,l+1,np+1,mp,iupx) else call updatelr(f13,np+1,mp,l+1,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l+1 f13( 1,j,k) = (ibcx-1)*f13(2,j,k) + ibcx*f13(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l+1 f13(np+1,j,k) = (ibcx-1)*f13(np,j,k) + . ibcx*f13(np+3,j,k) end do end do end if #endif compute G*tau22=d*km*d22 at (i, j +- 1/2, k) if (j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp +j3*topedge #endif do k=1,l do j=jllim,julim do i=1,np den=0.5*(rho(i,j-j3,k)+rho(i,j,k)) Kma=0.5*(Km(i,j-j3,k)+Km(i,j,k)) d22 = f22(i,j,k) f22(i,j,k) = den*Kma*d22 end do end do end do #if (POLES == 0) create boundary conditions at j=1 and m+1 if (topedge.eq.0) then call updatebt(f22,np,mp,l,np,mp+1,iupy) else call updatebt(f22,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l do i=1,np f22(i,1 ,k)=(ibcy-1)*f22(i,2 ,k)+ibcy*f22(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np f22(i,mp+1,k)=(ibcy-1)*f22(i,mp,k)+ibcy*f22(i,mp+3,k) end do end do end if #endif else jllim = 1 julim = mp + j3*topedge do k=1,l do j=jllim,julim do i=1,np f22(i,j,k)=0. end do end do end do end if compute d23 and G*tau23=d*km*d23 at (i, j +- 1/2, k +- 1/2) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif do k=2,l do j=jllim,julim do i=1,np den=0.25*(rho(i,j-j3,k-1)+rho(i,j,k-1) . +rho(i,j-j3,k )+rho(i,j,k )) Kma=0.25*(Km(i,j-j3,k-1)+Km(i,j,k-1) . +Km(i,j-j3,k )+Km(i,j,k )) d23 = f23(i,j,k) f23(i,j,k) = den*Kma*d23 end do end do end do create boundary condition at k=1 and l+1 (for j=1,m+1) if(ibcz.eq.0) then do j=jllim,julim do i=1,np den=0.25*(3.*(rho(i,j,2)+rho(i,j-j3,2)) . -(rho(i,j,1)+rho(i,j-j3,1)) ) Kma=0.25*(Km(i,j-j3,1)+Km(i,j,1)+Km(i,j-j3,2)+Km(i,j,2)) f23(i,j,1) = den*Kma*f23(i,j,1) den=0.25*(3.*(rho(i,j,L )+rho(i,j-j3,L )) . -(rho(i,j,L-1)+rho(i,j-j3,L-1)) ) Kma=0.25*(Km(i,j-j3,L)+Km(i,j,L)+Km(i,j-j3,L-1)+Km(i,j,L-1)) f23(i,j,L+1) = den*Kma*f23(i,j,L+1) end do end do else do j=jllim,julim do i=1,np f23(i,j, 1 ) = f23(i,j,L) f23(i,j,L+1) = f23(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at j=1 and m+1 (for k=2,l) if (topedge.eq.0) then call updatebt(f23,np,mp,l+1,np,mp+1,iupy) else call updatebt(f23,np,mp+1,l+1,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,np f23(i,1 ,k)=(ibcy-1)*f23(i,2 ,k)+ibcy*f23(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l+1 do i=1,np f23(i,mp+1,k)=(ibcy-1)*f23(i,mp,k)+ibcy*f23(i,mp+3,k) end do end do end if #endif compute d33 and G*tau33=d*km*d33 at (i, j, k +- 1/2) do k=2,L do j=1,mp do i=1,np den=0.5*(rho(i,j,k-1)+rho(i,j,k)) Kma=0.5*(Km(i,j,k-1)+Km(i,j,k)) d33 = f33(i,j,k) f33(i,j,k) = den*Kma*d33 end do end do end do create boundary conditions at k=1 if(ibcz.eq.0) then do j=1,mp do i=1,np den=0.5*(3.*rho(i,j,1)-rho(i,j,2)) Kma=0.5*(Km(i,j,1)+Km(i,j,2)) f33(i,j,1) = den*Kma*f33(i,j,1) end do end do else do j=1,mp do i=1,np f33(i,j,1) = f33(i,j,L) end do end do endif Compute stress force compute z-component of stress force compute tau33=gi*G*tau33 + g13*G*tau13 + g23*G*tau23 at (i,j,k+-1/2) if (rightedge.eq.0) then call updatelr(f13,np,mp,l+1,np+1,mp,1) else call updatelr(f13,np+1,mp,l+1,np+1,mp,1) end if if (topedge.eq.0) then call updatebt(f23,np,mp,l+1,np,mp+1,1) else call updatebt(f23,np,mp+1,l+1,np,mp+1,1) end if do k=2,L do j=1,mp do i=1,np tau33 =gi(i,j)*f33(i,j,k) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.5*(f13(i,j ,k)+f13(i+1,j ,k)) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.5*(f23(i,j ,k)+f23(i ,j+1,k)) temp(i,j,k)=tau33 end do end do end do if(ibcz.eq.0) then do j=1,mp do i=1,np tau331 =gi(i,j)*f33(i,j,1) . +0.5*(3.*gmul(1)-gmul(2))*s13(i,j)* . 0.5*(f13(i,j ,1)+f13(i+1,j ,1)) . +0.5*(3.*gmul(1)-gmul(2))*s23(i,j)* . 0.5*(f23(i,j ,1)+f23(i ,j+1,1)) temp(i,j, 1 )=tau331 temp(i,j,L+1) = 2.*temp(i,j,L)-temp(i,j,L-1) scr1(i,j,1)=0.5*(temp(i,j,1)+temp(i,j,2)) !store for bcs end do end do else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) scr1(i,j,1)=0.5*(temp(i,j,1)+temp(i,j,2)) !store for bcs end do end do endif do k=1,L do j=1,mp do i=1,np fw(i,j,k) = fw(i,j,k) + . ( 0.5*tc*dxi*( f13(i+1,j ,k) + f13(i+1,j ,k+1) . - f13(i ,j ,k) - f13(i ,j ,k+1) ) . +0.5*tc*dyi*( f23(i ,j+1,k) + f23(i ,j+1,k+1) . - f23(i ,j ,k) - f23(i ,j ,k+1) )*j3 . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)) )/rho(i,j,k) end do end do end do if (itraj.eq.1) then do k=1,L do j=1,mp do i=1,np fo(i,j,k) = fo(i,j,k) + gi(i,j)*fw(i,j,k) end do end do end do end if compute x-component of stress force compute tau13=gi*G*tau13 + g13*G*tau11 + g23*G*tau12 at (i,j,k+-1/2) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f11,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1,1) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1,1) end if if (rightedge.eq.0 .and. topedge.eq.0) then call update(f12,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(f12,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(f12,np,mp+1,l,np+1,mp+1,1) else call update(f12,np+1,mp+1,l,np+1,mp+1,1) end if do k=2,L do j=1,mp do i=1,np tau13 =0.5*gi(i,j)*(f13(i,j,k)+f13(i+1,j,k)) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.25*( f11(i,j,k-1)+f11(i+1,j,k-1) . +f11(i,j,k )+f11(i+1,j,k ) ) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.125*( f12(i,j ,k-1)+f12(i+1,j ,k-1) . +f12(i,j+1,k-1)+f12(i+1,j+1,k-1) . +f12(i,j ,k )+f12(i+1,j ,k ) . +f12(i,j+1,k )+f12(i+1,j+1,k ) ) temp(i,j,k)=tau13 end do end do end do complete with boundary condition if(ibcz.eq.0) then do j=1,mp ! tau13=stress*sin(a) - hx*tau33 do i=1,np hx=-s13(i,j)/gi(i,j)*zb !hx=-G*G13, at z=0 hy=-s23(i,j)/gi(i,j)*zb !hy=-G*G23, at z=0 hn=sqrt(1.+hx**2+hy**2) !===G*G33**1/2 taul=hn*tauw(i,j)*gi(i,j)*(u(i,j,1)+hx*w(i,j,1)) temp(i,j,1)=2.*(taul-hx*scr1(i,j,1))-temp(i,j,2) temp(i,j,l+1) = -temp(i,j,l) enddo enddo else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) enddo enddo endif do k=1,l do j=1,mp do i=1,np fu(i,j,k) = fu(i,j,k) + . ( tc*dxi*( f11(i+1,j ,k) - f11(i ,j ,k) ) . + 0.5*tc*dyi*( f12(i ,j+1,k) + f12(i+1,j+1,k) . - f12(i ,j ,k) - f12(i+1,j ,k) )*j3 . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)) )/rho(i,j,k) end do end do end do if (itraj.eq.1) then do k=1,l do j=1,mp do i=1,np g13=gmul(k)*s13(i,j) fo(i,j,k) = fo(i,j,k) + g13*fu(i,j,k) end do end do end do end if compute y-component of stress force compute tau23=gi*G*tau23 + g13*G*tau12 + g23*G*tau22 at (i,j,k+-1/2) if (topedge.eq.0) then call updatebt(f22,np,mp,l,np,mp+1,1) else call updatebt(f22,np,mp+1,l,np,mp+1,1) end if do k=2,l do j=1,mp do i=1,np tau23 =0.5*gi(i,j)*(f23(i,j,k)+f23(i,j+1,k)) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.125*( f12(i,j ,k-1)+f12(i+1,j ,k-1) . + f12(i,j+1,k-1)+f12(i+1,j+1,k-1) . + f12(i,j ,k )+f12(i+1,j ,k ) . + f12(i,j+1,k )+f12(i+1,j+1,k ) ) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.25* ( f22(i,j,k-1)+f22(i,j+1,k-1) . + f22(i,j,k )+f22(i,j+1,k ) ) temp(i,j,k)=tau23 end do end do end do if(ibcz.eq.0) then complete with boundary condition do j=1,mp ! tau23=stress*cos(a) - hy*tau33 do i=1,np hx=-s13(i,j)/gi(i,j)*zb !hx=-G*G13, at z=0 hy=-s23(i,j)/gi(i,j)*zb !hy=-G*G23, at z=0 hn=sqrt(1.+hx**2+hy**2) !===G*G33**1/2 taul=hn*tauw(i,j)*gi(i,j)*(v(i,j,1)+hy*w(i,j,1)) temp(i,j,1)=2.*(taul-hy*scr1(i,j,1))-temp(i,j,2) temp(i,j,l+1) = -temp(i,j,l) enddo enddo else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) enddo enddo endif do k=1,L do j=1,mp do i=1,np fv(i,j,k) = fv(i,j,k) + . (0.5*tc*dxi*( f12(i+1,j ,k) + f12(i+1,j+1,k) . - f12(i ,j ,k) - f12(i ,j+1,k) ) . + tc*dyi*( f22(i ,j+1,k) - f22(i ,j ,k) ) . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)))/rho(i,j,k) end do end do end do if (j3.eq.1) then if (itraj.eq.1) then do k=1,L do j=1,mp do i=1,np g23=gmul(k)*s23(i,j) fo(i,j,k) = fo(i,j,k) + g23*fv(i,j,k) end do end do end do end if end if if(noslip.eq.1) then #if (POLES == 0) if(leftedge.eq.1) then do k=1,l do j=1,mp c fu(1,j,k)=0. fv(1,j,k)=0. fw(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c fu(np,j,k)=0. fv(np,j,k)=0. fw(np,j,k)=0. enddo enddo endif #endif c noslip lower boundary do j=1,mp do i=1,np fu(i,j,1)=0. fv(i,j,1)=0. fw(i,j,1)=0. c fu(i,j,l)=0. c fv(i,j,l)=0. c fw(i,j,l)=0. enddo enddo endif do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+2.*fu(i,j,k) fy(i,j,k)=fy(i,j,k)+2.*fv(i,j,k) fz(i,j,k)=fz(i,j,k)+2.*fw(i,j,k) enddo enddo enddo if(itraj.eq.1) then do k=1,l do j=1,mp do i=1,np fomeg(i,j,k)=fomeg(i,j,k)+2.*fo(i,j,k) enddo enddo enddo endif compute subgrid-scale forcings for scalar variables c note scr1,scr2,f33,and temp are work arrays and are destroyed. do k=1,l do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo call lapdf(th,scr3,Km,Prinv,scr1,scr2,f33,temp,1) do k=1,l do j=1,mp do i=1,np ft(i,j,k)=ft(i,j,k)+2.*scr3(i,j,k) th(i,j,k)=th(i,j,k)-the(i,j,k) enddo enddo enddo call update(th,np,mp,l,np,mp,1) call update(fu,np,mp,l,np,mp,1) call update(fv,np,mp,l,np,mp,1) call update(fw,np,mp,l,np,mp,1) call update(ft,np,mp,l,np,mp,1) if(ichm.eq.1) then do ispc=1,nspc call lapdf(chm(1-ih,1-ih,1,ispc), . scr3,Km,Prinv,scr1,scr2,f33,temp,0) do k=1,l do j=1,mp do i=1,np fchm(i,j,k,ispc)=fchm(i,j,k,ispc)+2.*scr3(i,j,k) enddo enddo enddo call update(fchm(1-ih,1-ih,1,ispc),np,mp,l,np,mp,1) enddo endif #if (MOISTMOD > 0) if(moist.eq.1) then call lapdf(qv,scr3,Km,Prinv,scr1,scr2,f33,temp,-1) do k=1,l do j=1,mp do i=1,np fqv(i,j,k)=fqv(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call lapdf(qc,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqc(i,j,k)=fqc(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call lapdf(qr,scr3,Km,Prinv,scr1,scr2,f33,temp,-3) do k=1,l do j=1,mp do i=1,np fqr(i,j,k)=fqr(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call update(fqv,np,mp,l,np,mp,1) call update(fqc,np,mp,l,np,mp,1) call update(fqr,np,mp,l,np,mp,1) #if (MOISTMOD == 2) if(iceab.eq.1) then call lapdf(qia,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqia(i,j,k)=fqia(i,j,k)+2.*scr3(i,j,k) enddo enddo end do call lapdf(qib,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqib(i,j,k)=fqib(i,j,k)+2.*scr3(i,j,k) enddo enddo end do call update(fqia,np,mp,l,np,mp,1) call update(fqib,np,mp,l,np,mp,1) endif #endif endif #endif c #if (TIMEPLT == 1) call ttend(47) #endif return end subroutine stress0(u,v,w,th,qv,qc,qr,qia,qib,fx,fy,fz,fomeg, 1 fu,fv,fw,fo,ft,fqv,fqc,fqr,fqia,fqib,Prinv,Km,scr1) include 'param.nml' include 'msg.inc' real u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:np+ih, 1-ih:mp+ih, l), . fy(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fo(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fomeg(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts) common/blank/ scr3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . f33(1-ih:np+ih, 1-ih:mp+ih, l), . scr12(1-ih:np+ih, 1-ih:mp+ih, l, 12) parameter(iblank=12*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ f11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f22(1-ih:np+ih, 1-ih:mp+ih+1, l), * f23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . f13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * temp(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) c Calculation of the RHS in the prognostic equations, c diffusion terms obtained using km from the TKE-equation (sub."tkefrc") c inputs include Prinv = 1/Pr/pri, Km, f11,...,f23, containing the six c components of the deformation tensor. scr1, scr2, scr3, and temp c are work arrays. c Output: fu,fv,fw,ft,fqv,fqc,fqr. c Note that the subroutine is called only when ivisc=1 and itke=1. c This subroutine calls subroutines lapdf to calculate diffusion terms. common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real den,Kma,tau13,tau23,tau33,tc #if (TIMEPLT == 1) call ttbeg(47) #endif c fourth order diffusion == - , + 2x lapdf c tc=-2. c simple Laplacian tc=2. c make sure to change bc in lapdf do 1 k=1,l do 1 j=1,mp do 1 i=1,np c Prinv(i,j,k)=1. c Km(i,j,k)=200. c Km(i,j,k)=100. c Km(i,j,k)= 50. c Km(i,j,k)= 25. c for stratified flows, different vertical diffusion from horizontal c Prinv(i,j,k)=1.e-30 c Km(i,j,k)=18257.4186 c Km(i,j,k)=89442.7191 Kmij=1.004e-6 Km(i,j,k)=Kmij u(i,j,k)=u(i,j,k)-ue(i,j,k) v(i,j,k)=v(i,j,k)-ve(i,j,k) 1 continue call lapdf(u,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 10 k=1,l do 10 j=1,mp do 10 i=1,np fx(i,j,k)=fx(i,j,k)+tc*scr3(i,j,k) 10 u(i,j,k)=u(i,j,k)+ue(i,j,k) call lapdf(v,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 11 k=1,l do 11 j=1,mp do 11 i=1,np fy(i,j,k)=fy(i,j,k)+tc*scr3(i,j,k) 11 v(i,j,k)=v(i,j,k)+ve(i,j,k) call lapdf(w,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 12 k=1,l do 12 j=1,mp do 12 i=1,np 12 fz(i,j,k)=fz(i,j,k)+tc*scr3(i,j,k) compute subgrid-scale forcings for scalar variables c note scr1,scr2,f33,and temp are work arrays and are destroyed. call lapdf(th,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) do 13 k=1,l do 13 j=1,mp do 13 i=1,np 13 ft(i,j,k)=ft(i,j,k)+tc*scr3(i,j,k) #if (MOISTMOD > 0) if(moist.eq.1) then call lapdf(qv,scr3,Km,Prinv,scr1,scr2,f33,temp,-1) do 14 k=1,l do 14 j=1,mp do 14 i=1,np 14 fqv(i,j,k)=fqv(i,j,k)+tc*scr3(i,j,k) call lapdf(qc,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do 15 k=1,l do 15 j=1,mp do 15 i=1,np 15 fqc(i,j,k)=fqc(i,j,k)+tc*scr3(i,j,k) call lapdf(qr,scr3,Km,Prinv,scr1,scr2,f33,temp,-3) do 16 k=1,l do 16 j=1,mp do 16 i=1,np 16 fqr(i,j,k)=fqr(i,j,k)+tc*scr3(i,j,k) endif #endif c #if (TIMEPLT == 1) call ttend(47) #endif return end #endif /* endif SGS == 1 */ #if (SGS == 2) subroutine dissip(ox,oy,oz,u0,v0,w0,th,qv,qc,qr,tke,fx,fy,fz,ft 1 ,fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l), . ths(1-ih:np+ih,1-ih:mp+ih,l), . fts(1-ih:np+ih,1-ih:mp+ih,l) real *8 thdp(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/mihaistr/ acns,beta,dzb,hpsl,kst common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/sgscnst/ ceps,cL,cm,css,prndt common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/diffus/ sk(l),skr(l),sls common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z #if (TIMEPLT == 1) call ttbeg(40) #endif c ... determine the number of iterations for viscous term pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 = maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=1. cdrgx(2)=1. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=1. cdrgz(2)=1. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity abscl=5.7e3 * 3. do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih rhon=1. tke(i,j,k)=sk(k)*rhon enddo enddo enddo call indexdef call normalv c treat radiative, momentum and temp. diffusion iradt=0 if(iradt.eq.1) then !treat radiative, momentum and temp. diffusion do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) oxs(i,j,k)=ox(i,j,k) oys(i,j,k)=oy(i,j,k) ozs(i,j,k)=oz(i,j,k) ths(i,j,k)=th(i,j,k) enddo enddo enddo DO itr=1,ntau call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) c call strainst(ox,oy,oz,u0,v0,w0,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) if(icylind.eq.1.and.noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp c u1(1,j,k)=0. v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. u1(i,j,l)=0. v1(i,j,l)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np c fx(i,j,k)=fx(i,j,k)+2.*u1(i,j,k) c fy(i,j,k)=fy(i,j,k)+2.*v1(i,j,k) c fz(i,j,k)=fz(i,j,k)+2.*w1(i,j,k) fx(i,j,k)=fx(i,j,k)+rat*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+rat*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+rat*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) oxs(i,j,k)=oxs(i,j,k)+strxd(i,j) oys(i,j,k)=oys(i,j,k)+stryd(i,j) ozs(i,j,k)=ozs(i,j,k)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 endif enddo enddo enddo ENDDO !itr=1,ntau endif !iradt if(itraj.eq.1) then ! if using RK time integration do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox1(i,j,k)=g11*u1(i,j,k)+g21*v1(i,j,k) oy1(i,j,k)=g12*u1(i,j,k)+g22*v1(i,j,k) oz1(i,j,k)=g13*u1(i,j,k)+g23*v1(i,j,k)+g33*w1(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox1,oy1,oz1,-1) do k=1,l do j=1,mp do i=1,np fox(i,j,k)=fox(i,j,k)+2.*ox1(i,j,k) foy(i,j,k)=foy(i,j,k)+2.*oy1(i,j,k) foz(i,j,k)=foz(i,j,k)+2.*oz1(i,j,k) enddo enddo enddo endif c ------------------------------ c ---- specify surface fluxes for diffusive scalar field (heat...) do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo c ... working with full theta or just with perturbation c ifull=1 ifull=0 do k=1,l do j=1,mp do i=1,np ths(i,j,k)=th(i,j,k) enddo enddo enddo if(iradt.eq.1) then !treat radiative, momentum and temp. diffusion c ... determine the number of iterations for diffusion term pri=1./prndt c00 = pri*maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) DO itr=1,ntau do k=1,lkv do j=1,mkvp do i=1,nkvp tke(i,j,k)=pri*sk(k)*trs(k)/the(i,j,k) thdp(i,j,k)=ifull*the(i,j,k) thdp(i,j,k)=thdp(i,j,k)+ths(i,j,k) ths(i,j,k)=thdp(i,j,k) enddo enddo enddo call fckflxdv(ths,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,lkv do j=1,mkvp do i=1,nkvp c ft(i,j,k)=ft(i,j,k)+2.*v1(i,j,k)*the(i,j,k)/trs(k) ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*the(i,j,k)/trs(k) c division by rho is made in routine fckflxdv thdp(i,j,k)=thdp(i,j,k)-ifull*the(i,j,k) ths(i,j,k)=thdp(i,j,k) ths(i,j,k)= ths(i,j,k)+dtau*v1(i,j,k) enddo enddo enddo ENDDO !itr=1,ntau endif !iradt c ... determine the number of iterations for radiative diffusion term c00 = maxval(skr) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) do k=1,lkv do j=1,mkvp do i=1,nkvp tke(i,j,k)=skr(k) enddo enddo enddo DO itr=1,ntau do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c u1(i,j,k)=trs(k)*(ifull+ths(i,j,k)/the(i,j,k)) u1(i,j,k)=trs(k)*(ifull+ths(i,j,k)/thrs(k)) enddo enddo enddo call fckflxdv(u1,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,lkv do j=1,mkvp do i=1,nkvp c ft(i,j,k)=ft(i,j,k)+2.*v1(i,j,k)*the(i,j,k)/trs(k) c ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*the(i,j,k)/trs(k) ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*thrs(k)/trs(k) c division by rho is made in routine fckflxdv if(itr.ne.ntau) then ths(i,j,k)= ths(i,j,k)+dtau*v1(i,j,k) endif enddo enddo enddo ENDDO !itr=1,ntau #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine dissis(ox,oy,oz,u0,v0,w0,th, qv,qc,qr,tke, fx,fy,fz,ft, 1 fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/dissbc/ cstab,c00,c0h,dlstb,dtah,dtau,ntah,ntau common/sgscnst/ ceps,cL,cm,css,prndt common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/diffus/ sk(l),skr(l),sls common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) #if (TIMEPLT == 1) call ttbeg(40) #endif pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 =-1.e-10 do k=1,L c00=amax1(c00,sk(k)) enddo rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau ratq=2.*(dtau/dt) c0h=-1.e-10 do k=1,L c c0h=amax1(c0h,sk(k)*(trs(k)/the(1,1,k))) c0h=amax1(c0h,sk(k)) enddo c0h=c0h/prndt rtah=c0h/cstab ntah=ifix(rtah+1.) dtah=dt/ntah rath=2.*(dtah/dt) c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=0. cdrgx(2)=0. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=0. cdrgz(2)=0. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c rhon=1. c rhon=(rho(i,j,lkv-k+1)/rho(i,j,1))**2 c rhon=sqrt(rho(i,j,lkv-k+1)/rho(i,j,1)) c tke(i,j,k)=c00*rhon tke(i,j,k)=sk(k) enddo enddo enddo call indexdef call normalv do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) oxs(i,j,k)=ox(i,j,k) oys(i,j,k)=oy(i,j,k) ozs(i,j,k)=oz(i,j,k) enddo enddo enddo isclrdf=1 DO itr=1,ntau if(isclrdf.eq.0) then call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) else do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo c call fckflxdv_V(us,u1,tke,pfx,pfy,pfz,hflx,hfly,hflz) c call fckflxdv_V(vs,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) c call fckflxdv_V(ws,w1,tke,pfx,pfy,pfz,hflx,hfly,hflz) endif if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+ratq*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+ratq*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+ratq*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) oxs(i,j,k)=oxs(i,j,k)+strxd(i,j) oys(i,j,k)=oys(i,j,k)+stryd(i,j) ozs(i,j,k)=ozs(i,j,k)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 endif enddo enddo enddo if(itraj.eq.1) then ! if using RK time integration do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox1(i,j,k)=g11*u1(i,j,k)+g21*v1(i,j,k) oy1(i,j,k)=g12*u1(i,j,k)+g22*v1(i,j,k) oz1(i,j,k)=g13*u1(i,j,k)+g23*v1(i,j,k)+g33*w1(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox1,oy1,oz1,-1) do k=1,l do j=1,mp do i=1,np fox(i,j,k)=fox(i,j,k)+ratq*ox1(i,j,k) foy(i,j,k)=foy(i,j,k)+ratq*oy1(i,j,k) foz(i,j,k)=foz(i,j,k)+ratq*oz1(i,j,k) enddo enddo enddo endif ENDDO !itr=1,ntau c--------------------------------------- c diffusion of heat c--------------------------------------- c ---- specify surface fluxes for diffusive scalar field (heat...) do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo ifull=0. hflbt= sls/(cp*4*pi*rds**2)*ifull hfltp= sls/(cp*4*pi*(rds+(l-1)*dz)**2)*ifull do k=1,l do j=1,mp do i=1,np ws(i,j,k)=th(i,j,k)+ifull*the(i,j,k) us(i,j,k)=ws(i,j,k)*(trs(k)/the(i,j,k)) enddo enddo enddo DO itr=1,ntah do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo do k=1,l do j=1,mp do i=1,np tke(i,j,k)=skr(k) c tke(i,j,k)=skr(j,k) enddo enddo enddo call fckflxdv(us,vs,tke,pfx,pfy,pfz,hflx,hfly,hflz) do j=1,mp do i=1,np hflz(i,j,1)= hflbt hflz(i,j,2)= hfltp enddo enddo do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih tke(i,j,k)=sk(k)*(trs(k)/the(i,j,k)) enddo enddo enddo call fckflxdv(ws,vs,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,l do j=1,mp do i=1,np vs(i,j,k)=vs(i,j,k)*(the(i,j,k)/trs(k)) ft(i,j,k)=ft(i,j,k)+rath*vs(i,j,k) if(itr.ne.ntah) then ws(i,j,k)= ws(i,j,k)+dtah*vs(i,j,k) us(i,j,k)=ws(i,j,k)*(trs(k)/the(i,j,k)) endif enddo enddo enddo ENDDO !itr=1,ntah #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine balhfl(a,d) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, 2), . d(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih), . tmp2(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else c real*8 sum real sum #endif real globsum !modgs c real*8 globsum illim=1+ibcx*leftedge jllim=1+ibcy*botedge do j=1,mp do i=1,np tmp1(i,j)=0. tmp2(i,j)=0. enddo enddo do j=jllim,mp do i=illim,np tmp1(i,j)=a(i,j,1)*d(i,j,1) tmp2(i,j)=a(i,j,1)*d(i,j,l) enddo enddo if(ibcx.eq.0 .and. leftedge.eq.1) then do j=jllim,mp tmp1(1,j)=tmp1(1,j)-0.5*a(1,j,1)*d(1,j,1) tmp2(1,j)=tmp2(1,j)-0.5*a(1,j,1)*d(1,j,l) enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do j=jllim,mp tmp1(np,j)=tmp1(np,j)-0.5*a(np,j,1)*d(np,j,1) tmp2(np,j)=tmp2(np,j)-0.5*a(np,j,1)*d(np,j,l) enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do i=illim,np tmp1(i,1)=tmp1(i,1)-0.5*a(i,1,1)*d(i,1,1) tmp2(i,1)=tmp2(i,1)-0.5*a(i,1,1)*d(i,1,l) enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do i=illim,np tmp1(i,mp)=tmp1(i,mp)-0.5*a(i,mp,1)*d(i,mp,1) tmp2(i,mp)=tmp2(i,mp)-0.5*a(i,mp,1)*d(i,mp,l) enddo endif sumbt=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,1, . illim,iulim,jllim,julim,1,1) sumtp=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,1, . illim,iulim,jllim,julim,1,1) do j=1,mp do i=1,np a(i,j,2)= a(i,j,1)*(sumbt/sumtp) enddo enddo return end subroutine dissipB(u0,v0,w0,tke,fx,fy,fz,pfx,pfy,pfz, . u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv) dimension pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/diffus/ sk(l),skr(l),sls common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) #if (TIMEPLT == 1) call ttbeg(40) #endif rhon=1.0 c rhon=100. c rhon=0.01 pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 =rhon*maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) c print *,'rtau=',rtau,'cstab=',cstab,'ntau=',ntau c pause 'dissip' c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=0. cdrgx(2)=0. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=0. cdrgz(2)=0. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c rhon=(rho(i,j,lkv-k+1)/rho(i,j,1))**2 c rhon=sqrt(rho(i,j,lkv-k+1)/rho(i,j,1)) c tke(i,j,k)=c00*rhon c tke(i,j,k)=sk(k) tke(i,j,k)=sk(k)*rhon enddo enddo enddo call indexdef call normalv do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) enddo enddo enddo DO itr=1,ntau call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp c u1(1,j,k)=0. v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. c u1(i,j,l)=0. c v1(i,j,l)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+rat*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+rat*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+rat*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) endif enddo enddo enddo c ------------------------------ ENDDO !itr=1,ntau do k=1,l do j=1,mp do i=1,np u1(i,j,k)=u0(i,j,k) v1(i,j,k)=v0(i,j,k) w1(i,j,k)=w0(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) include 'param.nml' include 'msg.inc' dimension ugx(1-ih:np+ih,1-ih:mp+ih,l), * ugy(1-ih:np+ih,1-ih:mp+ih,l), * ugz(1-ih:np+ih,1-ih:mp+ih,0:l), * vgx(1-ih:np+ih,1-ih:mp+ih,l), * vgy(1-ih:np+ih,1-ih:mp+ih,l), * vgz(1-ih:np+ih,1-ih:mp+ih,0:l), * wgx(1-ih:np+ih,1-ih:mp+ih,l), * wgy(1-ih:np+ih,1-ih:mp+ih,l), * wgz(1-ih:np+ih,1-ih:mp+ih,0:l) umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 il=1-leftedge do k=1,l do j=1,mp do i=il,np umx=amax1(umx,ugx(i,j,k)) umn=amin1(umn,ugx(i,j,k)) vmx=amax1(vmx,vgx(i,j,k)) vmn=amin1(vmn,vgx(i,j,k)) wmx=amax1(wmx,wgx(i,j,k)) wmn=amin1(wmn,wgx(i,j,k)) enddo enddo enddo umx=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umn=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmx=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmn=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmx=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmn=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print 201,umx,umn,vmx,vmn,wmx,wmn umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 jb=1-botedge do k=1,l do j=jb,mp do i=1,np umx=amax1(umx,ugy(i,j,k)) umn=amin1(umn,ugy(i,j,k)) vmx=amax1(vmx,vgy(i,j,k)) vmn=amin1(vmn,vgy(i,j,k)) wmx=amax1(wmx,wgy(i,j,k)) wmn=amin1(wmn,wgy(i,j,k)) enddo enddo enddo umx=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umn=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmx=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmn=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmx=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmn=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print 202,umx,umn,vmx,vmn,wmx,wmn umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 do k=0,l do j=1,mp do i=1,np umx=amax1(umx,ugz(i,j,k)) umn=amin1(umn,ugz(i,j,k)) vmx=amax1(vmx,vgz(i,j,k)) vmn=amin1(vmn,vgz(i,j,k)) wmx=amax1(wmx,wgz(i,j,k)) wmn=amin1(wmn,wgz(i,j,k)) if(umx.eq.ugz(i,j,k)) then iumx=i jumx=j kumx=k end if if(umn.eq.ugz(i,j,k)) then iumn=i jumn=j kumn=k end if enddo enddo enddo umxg=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umng=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmxg=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmng=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmxg=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmng=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) then print 203,umxg,umng,vmxg,vmng,wmxg,wmng endif if(umx.eq.umxg) print*,mype,' umx: (i,j,k) = ',iumx,jumx,kumx if(umn.eq.umng) print*,mype,' umn: (i,j,k) = ',iumn,jumn,kumn 201 format(1x,'ugxmx, ugxmn:',2e11.4/ . 1x,'vgxmx, vgxmn:',2e11.4/ . 1x,'wgxmx, wgxmn:',2e11.4) 202 format(1x,'ugymx, ugymn:',2e11.4/ . 1x,'vgymx, vgymn:',2e11.4/ . 1x,'wgymx, wgymn:',2e11.4) 203 format(1x,'ugzmx, ugzmn:',2e11.4/ . 1x,'vgzmx, vgzmn:',2e11.4/ . 1x,'wgzmx, wgzmn:',2e11.4) return end subroutine strainst(ox,oy,oz,u,v,w,ug,vg,eta) C C ******************************************* c * computes strain rate & viscous stress * c * elements in generalized coordinates * C ******************************************* c c eij - initially covariant strain rates; c finally contravariant stresses c eta - kinematic viscosity c ox, oy, oz - contravariant "xbar,ybar,zbar" components of c velocities in transformed coordinates c u, v, w - physical "x,y,z" components of velocity c in physical coordinates c ug - auxilliary velocity u*(gamma*cos(phi)) c v2 - auxilliary velocity v*gamma c C ******************************************* include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . ug(1-ih:np+ih,1-ih:mp+ih,l), . vg(1-ih:np+ih,1-ih:mp+ih,l), . eta(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . etai( nkvp, mkvp, lkv) common/strainc/ e11(1-ih:np+ih,1-ih:mp+ih,L), * e12(1-ih:np+ih,1-ih:mp+ih,L), * e13(1-ih:np+ih,1-ih:mp+ih,L), * e21(1-ih:np+ih,1-ih:mp+ih,L), * e22(1-ih:np+ih,1-ih:mp+ih,L), * e23(1-ih:np+ih,1-ih:mp+ih,L), * e31(1-ih:np+ih,1-ih:mp+ih,L), * e32(1-ih:np+ih,1-ih:mp+ih,L), * e33(1-ih:np+ih,1-ih:mp+ih,L), * e11bx(mp,l,2),e11by(np,l,2),e11bz(np,mp,2), * e12bx(mp,l,2),e12by(np,l,2),e12bz(np,mp,2), * e13bx(mp,l,2),e13by(np,l,2),e13bz(np,mp,2), * e21bx(mp,l,2),e21by(np,l,2),e21bz(np,mp,2), * e22bx(mp,l,2),e22by(np,l,2),e22bz(np,mp,2), * e23bx(mp,l,2),e23by(np,l,2),e23bz(np,mp,2), * e31bx(mp,l,2),e31by(np,l,2),e31bz(np,mp,2), * e32bx(mp,l,2),e32by(np,l,2),e32bz(np,mp,2), * e33bx(mp,l,2),e33by(np,l,2),e33bz(np,mp,2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iarrl1=(np+2*ih)*(mp+2*ih)*(l+1)) ! size of ugz,vgz,wgz parameter(iarrrh=(np+2)*(mp+2)*(l+2)) ! size of rh parameter(ifree=10*iarray-3*iarrl1-iarrrh) common/blank/ * ugx(1-ih:np+ih,1-ih:mp+ih,l), * ugy(1-ih:np+ih,1-ih:mp+ih,l), * ugz(1-ih:np+ih,1-ih:mp+ih,0:l), * vgx(1-ih:np+ih,1-ih:mp+ih,l), * vgy(1-ih:np+ih,1-ih:mp+ih,l), * vgz(1-ih:np+ih,1-ih:mp+ih,0:l), * wgx(1-ih:np+ih,1-ih:mp+ih,l), * wgy(1-ih:np+ih,1-ih:mp+ih,l), * wgz(1-ih:np+ih,1-ih:mp+ih,0:l), * rh(0:np+1,0:mp+1,0:l+1),src(ifree) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ diagstr(8),ivis,irid,itstr common/cmoist/ rv,t00,ee0,hlat #if (TIMEPLT == 1) call ttbeg(41) #endif compute some local constants ep=1.e-15 !bulk viscosity: Stoke's hypothesis c NOTE: 2nd law requires these are only MINIMUM values if(j3.eq.1) dii=-2./3. if(j3.eq.0) dii=-2./2. j3t=j3 !for eddy viscosity j3t may be set to 1 ied=0 !ied 0,1 for 1 and 2d representation of edges do k=1,l do j=1,mp do i=1,np etai(i,j,k)=1./amax1(eta(i,j,k),ep) enddo enddo enddo if(tt.le.tend) call vstrhat(ox,oy,oz, 1) ! make solendoidal vel. call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) call update2(ox,np,mp,l,np,mp,iup) call update2(oy,np,mp,l,np,mp,iup) call update2(oz,np,mp,l,np,mp,iup) c initialize output variables #if (POLES == 0) illim= 0-(iupx-1)*leftedge ! iulim=np+1+(iupx-1)*rightedge ! fill additional point jllim= 1-j3*(1+(iupy-1)*botedge) ! when ibcx=1 or ibcy=1 julim=mp+j3*(1+(iupy-1)*topedge) ! #else illim= 0 iulim=np+1 jllim= 1-j3 julim=mp+j3 #endif do k=1,l do j=jllim,julim do i=illim,iulim ug(i,j,k)=u(i,j,k)* . (1-icylind)*(cosa(i,j)*gmm(i,j,k))+icylind*1. ! update u,v,cosa,gmm vg(i,j,k)=v(i,j,k)*gmm(i,j,k) ! before this loop enddo enddo enddo #if (POLES == 0) illim= 0+leftedge iulim=np+1-rightedge jllim= 1-j3*(1-botedge) julim=mp+j3*(1-topedge) #endif do k=1,l do j=jllim,julim do i=illim,iulim rh(i,j,k)=rho(i,j,k) ! rho must be updated enddo enddo enddo #if (POLES == 0) c extend rho if(ibcx.eq.0) then if(leftedge.eq.1) then do k=1,l do j=jllim,julim rh( 0 ,j,k)=rh(1 ,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=jllim,julim rh(np+1,j,k)=rh(np,j,k) enddo enddo endif else if(leftedge.eq.1) then do k=1,l do j=jllim,julim rh( 0 ,j,k)=rho(-1 ,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=jllim,julim rh(np+1,j,k)=rho(np+2,j,k) enddo enddo endif endif if(ibcy.eq.0) then if(botedge.eq.1) then do k=1,l do i=0,np+1 rh(i,1-j3,k)=rh(i,1,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=0,np+1 rh(i,mp+j3,k)=rh(i,mp,k) enddo enddo endif else if(botedge.eq.1) then do k=1,l do i=illim,iulim rh(i,1-j3,k)=rho(i,1-2*j3,k) enddo enddo if(leftedge.eq.1) then do k=1,l rh(0,1-j3,k)=rho(-1,1-2*j3,k) enddo endif if(rightedge.eq.1) then do k=1,l rh(np+1,1-j3,k)=rho(np+2,1-2*j3,k) enddo endif endif if(topedge.eq.1) then do k=1,l do i=illim,iulim rh(i,mp+j3,k)=rho(i,mp+2*j3,k) enddo enddo if(leftedge.eq.1) then do k=1,l rh(0,mp+j3,k)=rho(-1,mp+2*j3,k) enddo endif if(rightedge.eq.1) then do k=1,l rh(np+1,mp+j3,k)=rho(np+2,mp+2*j3,k) enddo endif endif endif #endif do j=0,mp+1 do i=0,np+1 rh(i,j, 0 )=ibcz*rh(i,j,l-1)+(1-ibcz)*rh(i,j,1) rh(i,j,l+1)=ibcz*rh(i,j, 2 )+(1-ibcz)*rh(i,j,l) enddo enddo c ---------------------------------------------- c --- initialize staggered velocity derivatives c ---------------------------------------------- c c --- x-gradients do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif ugx(i,j,k)= dxi*(ug(i+1,j,k)-ug(i,j,k)) vgx(i,j,k)= dxi*(vg(i+1,j,k)-vg(i,j,k)) wgx(i,j,k)= dxi*( w(i+1,j,k)- w(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.0) then if(leftedge.eq.1) then do k=1,L do j=1,mp ugx(0,j,k)= ugx(1,j,k) vgx(0,j,k)= vgx(1,j,k) wgx(0,j,k)= wgx(1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp ugx(np,j,k)= ugx(np-1,j,k) vgx(np,j,k)= vgx(np-1,j,k) wgx(np,j,k)= wgx(np-1,j,k) enddo enddo endif else if(leftedge.eq.1) then do k=1,L do j=1,mp ugx(0,j,k)= dxi*(ug(1,j,k)-ug(-1,j,k)) vgx(0,j,k)= dxi*(vg(1,j,k)-vg(-1,j,k)) wgx(0,j,k)= dxi*( w(1,j,k)- w(-1,j,k)) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp ugx(np,j,k)= dxi*(ug(np+2,j,k)-ug(np,j,k)) vgx(np,j,k)= dxi*(vg(np+2,j,k)-vg(np,j,k)) wgx(np,j,k)= dxi*( w(np+2,j,k)- w(np,j,k)) enddo enddo endif endif #endif c --- y-gradients do k=1,L #if (POLES == 0) do j=0,mp-j3*topedge #else do j=0,mp #endif do i=1,np ugy(i,j,k)= dyi*(ug(i,j+j3,k)-ug(i,j,k)) vgy(i,j,k)= dyi*(vg(i,j+j3,k)-vg(i,j,k)) wgy(i,j,k)= dyi*( w(i,j+j3,k)- w(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.0) then if(botedge.eq.1) then do k=1,L do i=1,np ugy(i,0,k)= ugy(i,1,k) vgy(i,0,k)= vgy(i,1,k) wgy(i,0,k)= wgy(i,1,k) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np ugy(i,mp,k)= ugy(i,mp-j3,k) vgy(i,mp,k)= vgy(i,mp-j3,k) wgy(i,mp,k)= wgy(i,mp-j3,k) enddo enddo endif else if(botedge.eq.1) then do k=1,L do i=1,np ugy(i,0,k)= dyi*(ug(i,1,k)-ug(i,1-2*j3,k)) vgy(i,0,k)= dyi*(vg(i,1,k)-vg(i,1-2*j3,k)) wgy(i,0,k)= dyi*( w(i,1,k)- w(i,1-2*j3,k)) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np ugy(i,mp,k)= dyi*(ug(i,mp+2*j3,k)-ug(i,mp,k)) vgy(i,mp,k)= dyi*(vg(i,mp+2*j3,k)-vg(i,mp,k)) wgy(i,mp,k)= dyi*( w(i,mp+2*j3,k)- w(i,mp,k)) enddo enddo endif endif #endif c --- z-gradients do k=1,L-1 do j=1,mp do i=1,np ugz(i,j,k)= dzi*(ug(i,j,k+1)-ug(i,j,k)) vgz(i,j,k)= dzi*(vg(i,j,k+1)-vg(i,j,k)) wgz(i,j,k)= dzi*( w(i,j,k+1)- w(i,j,k)) enddo enddo enddo klt=L*(1-ibcz) krt=L*ibcz do j=1,mp do i=1,np ugz(i,j,klt)= ugz(i,j,l-1) ugz(i,j,krt)= ugz(i,j, 1 ) vgz(i,j,klt)= vgz(i,j,l-1) vgz(i,j,krt)= vgz(i,j, 1 ) wgz(i,j,klt)= wgz(i,j,l-1) wgz(i,j,krt)= wgz(i,j, 1 ) enddo enddo call updatebtw(ugx,0,np,1,mp,l,1,np,1,mp,iupy) call updatebtw(vgx,0,np,1,mp,l,1,np,1,mp,iupy) ! call updatebtw(wgx,0,np,1,mp,l,1,np,1,mp,iupy) ! call updatelrw(ugy,1,np,0,mp,l,1,np,1,mp,iupx) ! call updatelrw(vgy,1,np,0,mp,l,1,np,1,mp,iupx) call updatelrw(wgy,1,np,0,mp,l,1,np,1,mp,iupx) ! call update(ugz,np,mp,l+1,np,mp,iup) call update(vgz,np,mp,l+1,np,mp,iup) call update(wgz,np,mp,l+1,np,mp,iup) c ---------------------------------------------- c --- completes staggered velocity derivatives with simple bcs c write (6,*) '**** strain: after initializations ****' c call extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) c ---------------------------------------------- c ---------------------------------------------- c --- compute surface vel. derivatives using drag c ---------------------------------------------- #if (POLES == 0) c --- left and right surfaces IF(IBCX.EQ.0) THEN IF(icylind.eq.1.and.noslip.eq.1) THEN ! utilize noslip BC do i=1,np,np-1 ! values are 1 or np if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then isign=(np+1-2*i)/(np-1) ! values are 1 or -1 im=i+(np+1-2*i)/(np-1) ! values are 2 or np-1 iu=i+2*isign ! values are 3 or np-2 is=(i-1)/(np-1)*np ! values are 0 or 1 do j=1+j3-ibcy,mp-j3+ibcy do k=2-ibcz,l-1+ibcz vgx(is,j,k)=-(2.*vg(i,j,k)-3.*vg(im,j,k)+vg(iu,j,k))*dxi*isign*j3 wgx(is,j,k)=-(2.* w(i,j,k)-3.* w(im,j,k)+ w(iu,j,k))*dxi*isign end do end do endif end do ELSE ! utilize drag force law (partial or full slip) j1ed=1+(j3-ibcy)*botedge*ied !ied option j2ed=mp-(j3-ibcy)*topedge*ied k1ed=1+(1-ibcz)*ied k2ed=l+(ibcz-1)*ied do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) isign=(np+1-2*i)/(np-1) c --- compute vgx and wgx on left and right surfaces do 10 j=j1ed,j2ed do 10 k=k1ed,k2ed c do 10 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge c do 10 k=2-ibcz,l-1+ibcz gf110=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) gnr=sqrt(1.+gf21**2) pnx= 1./gnr*isign ! components of unit normal pny=gf21/gnr*isign pnz= 0.*isign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauxy(j,k,ii)=cdrgx(ii)*vlt*(v(i,j,k)-vln*pny) !drag force y tauxz(j,k,ii)=cdrgx(ii)*vlt*(w(i,j,k)-vln*pnz) !drag force z drhdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k )) + /(rh(i+1,j ,k )+rh(i-1,j ,k )+ep) drhdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k )) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k )+ep) drhdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ay1=gf11*pnx+2.*gf21*pny*gf110/gmm(i,j,k) az2=gf11*pnx+gf21*pny*gf110/gmm(i,j,k) ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) ugy0=0.5*(ugy(i,j,k)+ugy(i ,j-j3,k )) ugz0=0.5*(ugz(i,j,k)+ugz(i ,j ,k-1)) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) vgz0=0.5*(vgz(i,j,k)+vgz(i ,j ,k-1)) wgy0=0.5*(wgy(i,j,k)+wgy(i ,j-j3,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) ry=tauxy(j,k,ii)*gmm(i,j,k)*gf110*etai(i,j,k) . -dii*pny*dvcn*gmm(i,j,k)*gf110*j3t c ry=tauxy(j,k,ii)*gmm(i,j,k)*gf110/eta(i,j,k) c . -dii*pny*dvcn*gmm(i,j,k)*gf110 . -pnx*(gf21*ugx0+gf22*ugy0+gf23*ugz0+gf12*vgy0+gf13*vgz0) . -2.*pny*gf110*(gf22*vgy0+gf23*vgz0)/gmm(i,j,k) . -rdsi*(2.*pnx*u(i,j,k)*gmm(i,j,k)*sina(i,j) . +2.*pny*w(i,j,k)*gmm(i,j,k)*cosa(i,j))*(1-icylind) . -icylind*rdsi*(2.*pny*u(i,j,k)-pnx*v(i,j,k)) rz=tauxz(j,k,ii)*gf110*etai(i,j,k) c rz=tauxz(j,k,ii)*gf110/eta(i,j,k) . -pnx*(gf33*ugz0+gf12*wgy0+gf13*wgz0) . -pny*gf110*(gf33*vgz0+gf22*wgy0+gf23*wgz0)/gmm(i,j,k) . +rdsi*(2.*pnx*u(i,j,k)*cosa(i,j) . +2.*pny*v(i,j,k)*cosa(i,j))*(1-icylind) vgx0=ry/ay1*j3 ! d(vg)/dxb at surface wgx0=rz/az2 ! d(wg)/dxb at surface vgx(is,j,k)=2.*vgx0-vgx(ik,j,k)*j3 wgx(is,j,k)=2.*wgx0-wgx(ik,j,k) 10 continue endif enddo END IF ! noslip END IF c --- front and back surfaces IF(IBCY.EQ.0.and.J3.EQ.1) THEN IF(noslip.eq.1) THEN ! utilize noslip BC do j=1,mp,mp-j3 ! values are 1 or np if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jsign=(mp+1-2*j)/(mp-1) ! values are 1 or -1 jm=j+ jsign ! values are 2 or mp-1 ju=j+2*jsign ! values are 3 or mp-2 js=(j-1)/(mp-1)*mp ! values are 0 or mp do i=1,np do k=1,l ugy(i,js,k)=-(2.*vg(i,j,k)-3.*vg(i,jm,k)+vg(i,ju,k))*dyi*jsign wgy(i,js,k)=-(2.* w(i,j,k)-3.* w(i,jm,k)+ w(i,ju,k))*dyi*jsign end do end do endif end do ELSE ! utilize drag force law (partial or full slip) i1ed= 1+(1-ibcx)*leftedge*ied !ied option i2ed=np-(1-ibcx)*rightedge*ied k1ed=1+(1-ibcz)*ied k2ed=l+(ibcz-1)*ied do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) c --- compute ugy and wgy on front and back surfaces do 20 k=k1ed,k2ed do 20 i=i1ed,i2ed c do 20 k=2-ibcz,l-1+ibcz c do 20 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) gnr=sqrt(gf12**2+1.) pnx=gf12/gnr*jsign ! components of unit normal pny= 1./gnr*jsign pnz= 0.*jsign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauyx(i,k,jj)=cdrgy(jj)*vlt*(u(i,j,k)-vln*pnx) !drag force x tauyz(i,k,jj)=cdrgy(jj)*vlt*(w(i,j,k)-vln*pnz) !drag force z drhdxb=dxi*(rh(i+1,j,k)-rh(i-1,j,k)) + /(rh(i+1,j,k)+rh(i-1,j,k)+ep) drhdyb=dyi*(rh(i,j+j3,k)-rh(i,j-j3,k)) + /(rh(i,j+j3,k)+rh(i,j-j3,k)+ep) drhdzb=dzi*(rh(i,j,k+1)-rh(i,j,k-1)) + /(rh(i,j,k+1)+rh(i,j,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ax1=2.*gf12*pnx/cosa(i,j)+gf22*pny az2=gf12*pnx/cosa(i,j)+gf22*pny ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) ugz0=0.5*(ugz(i,j,k)+ugz(i ,j ,k-1)) vgx0=0.5*(vgx(i,j,k)+vgx(i-1,j ,k )) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) vgz0=0.5*(vgz(i,j,k)+vgz(i ,j ,k-1)) wgx0=0.5*(wgx(i,j,k)+wgx(i-1,j ,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) rx=tauyx(i,k,jj)*gmm(i,j,k)**2*cosa(i,j)*etai(i,j,k) c rx=tauyx(i,k,jj)*gmm(i,j,k)**2*cosa(i,j)/eta(i,j,k) . -dii*pnx*dvcn*gmm(i,j,k)**2*cosa(i,j) . -2.*pny*gmm(i,j,k)*sina(i,j)*rdsi*u(i,j,k) . -2.*pnx*rdsi*gmm(i,j,k)*cosa(i,j)* . (w(i,j,k)-v(i,j,k)*tnga(i,j)) . -2.*pnx*(gf11*ugx0+gf13*ugz0)/cosa(i,j) . -pny*(gf11*vgx0+gf12*vgy0+gf13*vgz0+gf21*ugx0+gf23*ugz0) rz=tauyz(i,k,jj)*gmm(i,j,k)*etai(i,j,k) c rz=tauyz(i,k,jj)*gmm(i,j,k)/eta(i,j,k) . +2.*rdsi*(pnx*u(i,j,k)+pny*v(i,j,k)) . -pny*(gf21*wgx0+gf23*wgz0+gf33*vgz0) . -pnx*(gf11*wgx0+gf13*wgz0+gf33*ugz0)/cosa(i,j) ugy0=rx/ax1*j3 ! d(ug)/dyb at surface wgy0=rz/az2*j3 ! d(wg)/dyb at surface ugy(i,js,k)=2.*ugy0-ugy(i,jk,k) wgy(i,js,k)=2.*wgy0-wgy(i,jk,k) 20 continue endif enddo END IF !noslip END IF #endif c --- bottom and top surfaces IF(IBCZ.EQ.0) THEN ! IF(icylind.eq.1.and.noslip.eq.1) THEN ! utilize noslip BC ! do k=1,l,l-1 do k=1,1,1 ! only do lower surface ksign=(l+1-2*k)/(l-1) km=k+(l+1-2*k)/(l-1) ! values are 2 or np-1 ku=k+2*ksign ! values are 3 or np-2 ks=(k-1)/(l-1)*l ! values are 0 or 1 do j=1,mp do i=1,np ugz(i,j,ks)=-(2.*ug(i,j,k)-3.*ug(i,j,km)+ug(i,j,ku))*dzi*ksign vgz(i,j,ks)=-(2.*vg(i,j,k)-3.*vg(i,j,km)+vg(i,j,ku))*dzi*ksign*j3 end do end do enddo ! ELSE ! use drag force calculation ! special Nils ! do 30 k=1,l,l-1 i1ed= 1+(1-ibcx)*leftedge*ied !ied option i2ed=np-(1-ibcx)*rightedge*ied j1ed=1+(j3-ibcy)*botedge*ied !ied option j2ed=mp-(j3-ibcy)*topedge*ied do 30 k=l,l,l-1 ! only do top kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) ksign=(l+1-2*k)/(l-1) c --- compute ugz and vgz on bottom and top surfaces #if (POLES == 0) do 30 j=j1ed,j2ed do 30 i=i1ed,i2ed c do 30 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge c do 30 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge #else do 30 j=1,mp do 30 i=1,np #endif gf110=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) zsx=-gf13/gf33 zsy=-gf23/gf33 gnr=sqrt(1.+zsx**2+zsy**2) pnx=-zsx/gnr*ksign ! components of unit normal pny=-zsy/gnr*ksign pnz= 1./gnr*ksign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauzx(i,j,kk)=cdrgz(kk)*vlt*(u(i,j,k)-vln*pnx) !drag force x tauzy(i,j,kk)=cdrgz(kk)*vlt*(v(i,j,k)-vln*pny) !drag force y drhdxb=dxi*(rh(i+1,j,k)-rh(i-1,j,k)) + /(rh(i+1,j,k)+rh(i-1,j,k)+ep) drhdyb=dyi*(rh(i,j+j3,k)-rh(i,j-j3,k)) + /(rh(i,j+j3,k)+rh(i,j-j3,k)+ep) drhdzb=dzi*(rh(i,j,k+1)-rh(i,j,k-1)) + /(rh(i,j,k+1)+rh(i,j,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ax1=2.*gf13*pnx/gf110+gf23*pny/gmm(i,j,k) . +gf33*pnz ax2=gf13*pny/gmm(i,j,k) ay1=gf23*pnx/gf110 ay2=gf13*pnx/gf110+2.*gf23*pny/gmm(i,j,k) . +gf33*pnz ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) vgx0=0.5*(vgx(i,j,k)+vgx(i-1,j ,k )) wgx0=0.5*(wgx(i,j,k)+wgx(i-1,j ,k )) ugy0=0.5*(ugy(i,j,k)+ugy(i ,j-j3,k )) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) wgy0=0.5*(wgy(i,j,k)+wgy(i ,j-j3,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) rx=tauzx(i,j,kk)*gf110*etai(i,j,k) c rx=tauzx(i,j,kk)*gf110/eta(i,j,k) . -dii*gf110*pnx*dvcn . -pnz*(gf11*wgx0+gf12*wgy0+gf13*wgz0) . -2.*pnx*(gf11*ugx0+gf12*ugy0)/gf110 . -pny*(gf21*ugx0+gf22*ugy0+gf11*vgx0+gf12*vgy0)/gmm(i,j,k) . +(u(i,j,k)*(pnz-tnga(i,j)*pny) . -pnx*(w(i,j,k)-v(i,j,k)*tnga(i,j))) . *rdsi*2.*cosa(i,j)*(1-icylind) . +icylind*pny*v(i,j,k)*rdsi/gmm(i,j,k) ry=tauzy(i,j,kk)*gmm(i,j,k)*etai(i,j,k) . -dii*gmm(i,j,k)*pny*dvcn*j3t c ry=tauzy(i,j,kk)*gmm(i,j,k)/eta(i,j,k) c . -dii*gmm(i,j,k)*pny*dvcn . -pnz*(gf21*wgx0+gf22*wgy0+gf23*wgz0) . -2.*pny*(gf21*vgx0+gf22*vgy0)/gmm(i,j,k) . -pnx*(gf21*ugx0+gf22*ugy0+gf11*vgx0+gf12*vgy0)/gf110 . +(2.*rdsi*(pnz*v(i,j,k)-pny*w(i,j,k)-pnx*u(i,j,k)*tnga(i,j))) . *(1-icylind)+icylind*2.*rdsi*(pnx*v(i,j,k)-pny*u(i,j,k)) ugz0= (ay2*rx-ax2*ry)/(ax1*ay2-ax2*ay1) ! d(ug)/dzb at surface vgz0=-(ay1*rx-ax1*ry)/(ax1*ay2-ax2*ay1)*j3 ! d(vg)/dzb at surface ugz(i,j,ks)=2.*ugz0-ugz(i,j,ki) vgz(i,j,ks)=2.*vgz0-vgz(i,j,ki) 30 continue ! END IF ! noslip END IF #if (POLES == 0) c ---------------------------------------------- IF(J3.EQ.1) THEN c c --- compute edge vel. derivatives using drag c --- and Taylor series extrapolation c ---------------------------------------------- IF(IBCX+IBCY.EQ.0) THEN c --- compute vgx, wgx, ugy, and wgy on vertical edges do 1 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) im=i+(np+1-2*i)/(np-1) isign=(np+1-2*i)/(np-1) do 11 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jm=j+(mp+1-2*j)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) do 111 k=2-ibcz,l-1+ibcz vgx(is,j,k)=vgx(is,jm,k)-vgx(ik,jm,k)+vgx(ik,j,k) wgx(is,j,k)=wgx(is,jm,k)-wgx(ik,jm,k)+wgx(ik,j,k) ugy(i,js,k)=ugy(im,js,k)-ugy(im,jk,k)+ugy(i,jk,k) wgy(i,js,k)=wgy(im,js,k)-wgy(im,jk,k)+wgy(i,jk,k) 111 continue endif 11 continue endif 1 continue END IF IF(IBCY+IBCZ.EQ.0) THEN c --- compute ugy, wgy, ugz, and vgz on horizontal front/back edges do 2 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp jm=j+(mp+1-2*j)/(mp-j3) js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) do 21 k=1,l,l-1 kk=1+k/l km=k+(l+1-2*k)/(l-1) ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) ksign=(l+1-2*k)/(l-1) do 211 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge ugy(i,js,k)=ugy(i,jk,k)-ugy(i,jk,km)+ugy(i,js,km) wgy(i,js,k)=wgy(i,jk,k)-wgy(i,jk,km)+wgy(i,js,km) ugz(i,j,ks)=ugz(i,jm,ks)-ugz(i,jm,ki)+ugz(i,j,ki) vgz(i,j,ks)=vgz(i,jm,ks)-vgz(i,jm,ki)+vgz(i,j,ki) 211 continue 21 continue endif 2 continue END IF END IF ! J3.eq.1 IF(IBCX+IBCZ.EQ.0) THEN c --- compute ugz, vgz, vgx, and wgx on horizontal left/right edges do 3 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np im=i+(np+1-2*i)/(np-1) ik=((np-2)*i+1)/(np-1) is=(i-1)/(np-1)*np isign=(np+1-2*i)/(np-1) do 31 k=1,l,l-1 ki=((l-2)*k+1)/(l-1) kk=1+k/l km=k+(l+1-2*k)/(l-1) ks=(k-1)/(l-1)*l ksign=(l+1-2*k)/(l-1) do 311 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge vgx(is,j,k)=vgx(ik,j,k)-vgx(ik,j,km)+vgx(is,j,km) wgx(is,j,k)=wgx(ik,j,k)-wgx(ik,j,km)+wgx(is,j,km) ugz(i,j,ks)=ugz(im,j,ks)-ugz(im,j,ki)+ugz(i,j,ki) vgz(i,j,ks)=vgz(im,j,ks)-vgz(im,j,ki)+vgz(i,j,ki) 311 continue 31 continue endif 3 continue END IF c ---------------------------------------------- ! edges completed c ---------------------------------------------- c ---------------------------------------------- c --- Taylor series extrapolation for corners c ---------------------------------------------- IF(IBCX+IBCY+IBCZ.EQ.0) THEN do i=1,np,np-1 ! values are 1 or n if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ik=((np-2)*i+1)/(np-1) ! values are 1 or n-1 im=i+(np+1-2*i)/(np-1) ! values are 2 or n-1 is=(i-1)/(np-1)*np ! values are 0 or n do j=1,mp,mp-j3 ! values are 1 or m if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jk=((mp-1-j3)*j+1)/(mp-j3) ! values are 1 or m-j3 jm=j+(mp+1-2*j)/(mp-j3) ! values are 2 or m-j3 js=(j-j3)/(mp-j3)*mp ! values are 0 or m do k=1,l,l-1 ! values are 1 or l ki=((l-2)*k+1)/(l-1) ! values are 1 or l-1 km=k+(l+1-2*k)/(l-1) ! values are 2 or l-1 ks=(k-1)/(l-1)*l ! values are 0 or l-1 vgx(is,j,k)=0.5*(vgx(is,j ,km)+vgx(is,jm,k ) . +vgx(ik,j ,k )-vgx(ik,jm,km)) wgx(is,j,k)=0.5*(wgx(is,j ,km)+wgx(is,jm,k ) . +wgx(ik,j ,k )-wgx(ik,jm,km)) ugy(i,js,k)=0.5*(ugy(i ,js,km)+ugy(i ,jk,k ) . +ugy(im,js,k )-ugy(im,jk,km)) wgy(i,js,k)=0.5*(wgy(i ,js,km)+wgy(i ,jk,k ) . +wgy(im,js,k )-wgy(im,jk,km)) ugz(i,j,ks)=0.5*(ugz(i ,j ,ki)+ugz(i ,jm,ks) . +ugz(im,j ,ks)-ugz(im,jm,ki)) vgz(i,j,ks)=0.5*(vgz(i ,j ,ki)+vgz(i ,jm,ks) . +vgz(im,j ,ks)-vgz(im,jm,ki)) end do endif end do endif end do END IF #endif c ---------------------------------------------- c --- completes staggered velocity derivatives c ---------------------------------------------- c if(mype.eq.0) then c write (6,*) ' ' c write (6,*) '**** strain: after completing VG.s ****' c endif c call extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) c ---------------------------------------------------------c c surface fluxes --------> c ---------------------------------------------------------c c Compute strain rates for shear components of c c viscous stress, dilatation for compressive stress, c c and add together to form viscous stress c c c c Note distinction between covariant forms _ij c c and contravariant forms ^ij c c c c Compute staggered values centered at: c c x -> i+1/2, y -> j+1/2; z -> k+1/2 c c ---------------------------------------------------------c c --------------------------------------------------------- Compute the e_11 element of the strain rate @ (i+1/2,j,k) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gf11=.5*(strxx(ip,j)+strxx(i,j)) gf12=.5*(stryx(ip,j)+stryx(i,j)) gf13=.5*( (s13(ip,j)*gmul(k)-h13(ip,j))*gmus(k) . +(s13( i,j)*gmul(k)-h13( i,j))*gmus(k) ) e11(i,j,k)=gf11*ugx(i,j,k) + +gf12*( ugy( i,j,k)+ugy( i,j-j3,k) + +ugy(ip,j,k)+ugy(ip,j-j3,k) )*.25 + +gf13*( ugz(ip,j,k)+ugz(ip,j,k-1) + +ugz( i,j,k)+ugz( i,j,k-1) )*.25 + +( (w(ip,j,k)-v(ip,j,k)*tnga(ip,j)) + *gmm(ip,j,k)*(cosa(ip,j))**2 + +(w( i,j,k)-v( i,j,k)*tnga( i,j)) + *gmm(i ,j,k)*(cosa(i ,j))**2)*.5*rdsi + *(1-icylind) Compute the dilatation @ (i+1/2,j,k) drhdxb=dxi*( rh(i+1,j ,k )-rh(i ,j ,k )) + /( rh(i+1,j ,k )+rh(i ,j ,k )+ep)*2. drhdyb=dyi*( rh(i+1,j+j3,k )-rh(i+1,j-j3,k ) + +rh(i ,j+j3,k )-rh(i ,j-j3,k ) ) + /( rh(i+1,j+j3,k )+rh(i+1,j-j3,k ) + +rh(i ,j+j3,k )+rh(i ,j-j3,k )+ep) drhdzb=dzi*( rh(i+1,j ,k+1)-rh(i+1,j ,k-1) + +rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /( rh(i+1,j ,k+1)+rh(i+1,j ,k-1) + +rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-.5*(ox(ip,j,k)+ox(i,j,k))*drhdxb + -.5*(oy(ip,j,k)+oy(i,j,k))*drhdyb + -.5*(oz(ip,j,k)+oz(i,j,k))*drhdzb Compute the stress @ (i+1/2,j,k) diss=(eta(ip,j,k)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm11=.5*((gmm(ip,j,k)*cosa(ip,j))**2+(gmm(i,j,k)*cosa(i,j))**2) + *(1-icylind) + icylind*1. gt11=.5*((gmm(ip,j,k)*cosa(ip,j))**4+(gmm(i,j,k)*cosa(i,j))**4) + *(1-icylind) + icylind*1. e11(i,j,k)=2.*diss*e11(i,j,k)/gt11+bvis*dvcn/gm11 !tau^11 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11bz(i,j,kk)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11by(i,k,jj)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11bx(j,k,ii)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_22 element of the strain rate @ (i,j+1/2,k) DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gf21=0.5*(strxy(i,jp)+strxy(i,j)) gf22=0.5*(stryy(i,jp)+stryy(i,j)) gf23=0.5*( (s23(i,jp)*gmul(k)-h23(i,jp))*gmus(k) . +(s23(i,j )*gmul(k)-h23(i,j ))*gmus(k) ) e22(i,j,k)=gf21*( vgx(i,jp,k)+vgx(i-1,jp,k) + +vgx(i,j ,k)+vgx(i-1,j ,k))*.25 + +gf22*vgy(i,j,k) + +gf23*( vgz(i,jp,k )+vgz(i,jp,k-1) + +vgz(i, j,k )+vgz(i, j,k-1) )*.25 + +(w(i,jp,k)*gmm(i,jp,k)+w(i,j,k)*gmm(i,j,k))*.5*rdsi + *(1-icylind) + +icylind*0.5*(gmm(i,j,k)*u(i,j,k)+gmm(i,jp,k)*u(i,jp,k))*rdsi Compute the dilatation @ (i,j+1/2,k) drhdxb=dxi*( rh(i+1,j+j3,k )-rh(i-1,j+j3,k ) + +rh(i+1,j ,k )-rh(i-1,j ,k )) + /(rh(i+1,j+j3,k )+rh(i-1,j+j3,k ) + +rh(i+1,j ,k )+rh(i-1,j ,k )+ep) drhdyb=dyi*( rh(i ,j+j3,k )-rh(i ,j ,k )) + /(rh(i ,j+j3,k )+rh(i ,j ,k )+ep)*2. drhdzb=dzi*( rh(i ,j+j3,k+1)-rh(i ,j+j3,k-1) + +rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j+j3,k+1)+rh(i ,j+j3,k-1) + +rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-0.5*(ox(i,jp,k)+ox(i,j,k))*drhdxb + -0.5*(oy(i,jp,k)+oy(i,j,k))*drhdyb + -0.5*(oz(i,jp,k)+oz(i,j,k))*drhdzb Compute the stress @ (i,j+1/2,k) diss=(eta(i,jp,k)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm22=.5*((gmm(i,jp,k))**2+(gmm(i,j,k))**2) gt22=.5*((gmm(i,jp,k))**4+(gmm(i,j,k))**4) e22(i,j,k)=2.*diss*e22(i,j,k)/gt22+bvis*dvcn/gm22*j3t !tau^22 c e22(i,j,k)=2.*diss*e22(i,j,k)/gt22+bvis*dvcn/gm22 !tau^22 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22bz(i,j,kk)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22bz(i,j,kk)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22by(i,k,jj)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22by(i,k,jj)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22bx(j,k,ii)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22bx(j,k,ii)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_33 element of the strain rate @ (i,j,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP DO I=1,NP gf33=0.5*(gi(i,j)*gmus(kp)+gi(i,j)*gmus(k)) e33(i,j,k)=gf33*wgz(i,j,k) Compute the dilatation @ (i,j,k+1/2) drhdxb=dxi*( rh(i+1,j,k+1) -rh(i-1,j,k+1) + +rh(i+1,j,k) -rh(i-1,j,k) ) + /( rh(i+1,j,k+1) +rh(i-1,j,k+1) + +rh(i+1,j,k) +rh(i-1,j,k)+ep) drhdyb=dyi*( rh(i,j+j3,k+1)-rh(i,j-j3,k+1) + +rh(i,j+j3,k) -rh(i,j-j3,k) ) + /( rh(i,j+j3,k+1)+rh(i,j-j3,k+1) + +rh(i,j+j3,k) +rh(i,j-j3,k)+ep) drhdzb=dzi*( rh(i,j,k+1) -rh(i,j,k)) + /(rh(i,j,k+1) +rh(i,j,k)+ep)*2. dvcn=-0.5*(ox(i,j,kp)+ox(i,j,k))*drhdxb + -0.5*(oy(i,j,kp)+oy(i,j,k))*drhdyb + -0.5*(oz(i,j,kp)+oz(i,j,k))*drhdzb Compute the stress @ (i,j,k+1/2) diss=(eta(i,j,kp)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm33=1. e33(i,j,k)=2.*diss*e33(i,j,k)+bvis*dvcn*gm33 !tau_33=tau^33 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33bz(i,j,kk)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33by(i,k,jj)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33bx(j,k,ii)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_12 element of the strain rate @ (i+1/2,j+1/2,k) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gg11=.125*( strxx(ip,jp)+strxx(i,j ) . +strxx(ip,j )+strxx(i,jp) ) gg12=.125*( stryx(ip,jp)+stryx(i,j ) . +stryx(ip,j )+stryx(i,jp) ) gg13=.125*( ( s13(ip,jp)*gmul(k)-h13(ip,jp))*gmus(k) . +( s13(i ,j )*gmul(k)-h13(i ,j ))*gmus(k) . +( s13(ip,j )*gmul(k)-h13(ip,j ))*gmus(k) . +( s13(i ,jp)*gmul(k)-h13(i ,jp))*gmus(k) ) gg21=.125*( strxy(ip,jp)+strxy(i ,j ) . +strxy(ip,j )+strxy(i ,jp) ) gg22=.125*( stryy(ip,jp)+stryy(i ,j ) . +stryy(ip,j )+stryy(i ,jp) ) gg23=.125*( ( s23(ip,jp)*gmul(k)-h23(ip,jp))*gmus(k) . +( s23(i ,j )*gmul(k)-h23(i ,j ))*gmus(k) . +( s23(ip,j )*gmul(k)-h23(ip,j ))*gmus(k) . +( s23(i ,jp)*gmul(k)-h23(i ,jp))*gmus(k) ) e12(i,j,k)=gg21*( ugx(i ,jp,k)+ugx(i ,j ,k))*.5 . +gg22*( ugy(ip,j ,k)+ugy(i ,j ,k))*.5 . +gg23*( ugz(ip,jp,k)+ugz(ip,jp,k-1) . +ugz(i ,jp,k)+ugz(i ,jp,k-1) . +ugz(ip,j ,k)+ugz(ip,j ,k-1) . +ugz(i ,j ,k)+ugz(i ,j ,k-1) )*.125 . +gg11*( vgx(i ,jp,k)+vgx(i ,j ,k))*.5 . +gg12*( vgy(ip,j ,k)+vgy(i ,j ,k))*.5 . +gg13*( vgz(ip,jp,k)+vgz(ip,jp,k-1) . +vgz(i ,jp,k)+vgz( i,jp,k-1) . +vgz(ip,j ,k)+vgz(ip,j ,k-1) . +vgz(i ,j ,k)+vgz( i,j ,k-1) )*.125 . +( u(ip,jp,k)*sina(ip,jp)*gmm(ip,jp,k) . +u(ip,j ,k)*sina(ip,j )*gmm(ip,j ,k) . +u(i ,jp,k)*sina(i ,jp)*gmm(i ,jp,k) . +u(i ,j ,k)*sina(i ,j )*gmm(i ,j ,k) )*0.25*rdsi . *(1-icylind) . -icylind*0.25*(v(ip,j,k)+v(ip,jp,k)+v(i,jp,k)+v(i,j,k))*rdsi Compute the stress @ (i+1/2,j+1/2,k) diss=(eta(ip,jp,k)+eta(i,jp,k)+eta(ip,j,k)+eta(i,j,k))*.25 ! kin. vis. gt12=( gmm(ip,jp,k)**4*cosa(ip,jp)**2 . +gmm(i ,jp,k)**4*cosa(i ,jp)**2 . +gmm(ip,j ,k)**4*cosa(ip,j )**2 . +gmm(i ,j ,k)**4*cosa(i ,j )**2 )*.25*(1-icylind) . +( gmm(ip,jp,k)**2+gmm(i ,jp,k)**2 . + gmm(ip,j ,k)**2+gmm(i ,j ,k)**2 )*.25*icylind e12(i,j,k)=2.*diss*e12(i,j,k)/gt12 !tau^12 e21(i,j,k)=e12(i,j,k) !tau^21 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2 *(1-icylind) . +gmm(i,j,k)**2 *icylind e12bz(i,j,kk)=2.*dissb*e12b/gt12b e21bz(i,j,kk)=e12bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2*(1-icylind) . +gmm(i,j,k)**2 *icylind e12by(i,k,jj)=2.*dissb*e12b/gt12b e21by(i,k,jj)=e12by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2*(1-icylind) . +gmm(i,j,k)**2 *icylind e12bx(j,k,ii)=2.*dissb*e12b/gt12b e21bx(j,k,ii)=e12bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_13 element of the strain rate @ (i+1/2,j,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP DO I=1,NP ip=ipp(i) gh33=0.125*( gi(ip,j)*gmus(kp)+gi(ip,j)*gmus(k ) . +gi(i ,j)*gmus(k )+gi(i ,j)*gmus(kp) ) gh11=0.125*( strxx(ip,j)+strxx(ip,j) . +strxx(i ,j)+strxx(i ,j) ) gh12=0.125*( stryx(ip,j )+stryx(ip,j ) . +stryx(i ,j )+stryx(i ,j ) ) gh13=0.125*( ( s13(ip,j)*gmul(kp)-h13(ip,j))*gmus(kp) . +( s13(ip,j)*gmul(k )-h13(ip,j))*gmus(k ) . +( s13(i ,j)*gmul(k )-h13(i ,j))*gmus(k ) . +( s13(i ,j)*gmul(kp)-h13(i ,j))*gmus(kp) ) e13(i,j,k)=gh33*(ugz(ip,j,k )+ugz(i ,j,k))*.5 + +gh11*(wgx(i ,j,kp)+wgx(i ,j,k))*.5 + +gh12*(wgy(ip,j,kp)+wgy(ip,j-j3,kp) + +wgy(ip,j, k)+wgy(ip,j-j3, k) + +wgy(i ,j,k )+wgy(i ,j-j3,k ) + +wgy(i ,j,kp)+wgy(i ,j-j3,kp) )*.125 + +gh13*(wgz(ip,j,k )+wgz(i,j,k))*.5 + -0.25*rdsi*( (u(ip,j,kp)+u(ip,j,k ))*cosa(ip,j) + +(u(i ,j,k )+u(i ,j,kp))*cosa(i ,j) )*(1-icylind) Compute the stress @ (i+1/2,j,k+1/2) diss=(eta(ip,j,kp)+eta(i,j,kp)+eta(ip,j,k)+eta(i,j,k))*.25 !kin. vis. gt13=((gmm(ip,j,kp)*cosa(ip,j))**2+(gmm(i,j,kp)*cosa(i,j))**2 + +(gmm(ip,j,k )*cosa(ip,j))**2+(gmm(i,j,k )*cosa(i,j))**2)*.25 + *(1-icylind)+icylind*1. e13(i,j,k)=2.*diss*e13(i,j,k)/gt13 !tau^13 e31(i,j,k)=e13(i,j,k) !tau^31 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13bz(i,j,kk)=2.*dissb*e13b/gt13b e31bz(i,j,kk)=e13bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13by(i,k,jj)=2.*dissb*e13b/gt13b e31by(i,k,jj)=e13by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13bx(j,k,ii)=2.*dissb*e13b/gt13b e31bx(j,k,ii)=e13bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_23 element of the strain rate @ (i,j+1/2,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP gi33=0.125*( gi(i,jp)*gmus(kp)+gi(i,jp)*gmus(k ) . +gi(i ,j)*gmus(k )+gi(i ,j)*gmus(kp) ) gi21=.125*( strxy(i,jp)+strxy(i,jp) . +strxy(i,j )+strxy(i,j ) ) gi22=0.125*( stryy(i,jp)+stryy(i,jp) . +stryy(i,j )+stryy(i,j ) ) gi23=0.125*( ( s23(i,jp)*gmul(kp)-h23(i,jp))*gmus(kp) . +( s23(i,jp)*gmul(k )-h23(i,jp))*gmus(k ) . +( s23(i,j )*gmul(k )-h23(i,j ))*gmus(k ) . +( s23(i,j )*gmul(kp)-h23(i,j ))*gmus(kp) ) e23(i,j,k)= gi33*(vgz(i,jp,k )+vgz(i,j,k))*.5 + +gi21*(wgx(i,jp,kp)+wgx(i-1,jp,kp) + +wgx(i,jp,k )+wgx(i-1,jp,k ) + +wgx(i,j ,k )+wgx(i-1,j ,k ) + +wgx(i,j ,kp)+wgx(i-1,j ,kp) )*.125 + +gi22*(wgy(i,j ,kp)+wgy(i,j,k))*.5 + +gi23*(wgz(i,jp,k )+wgz(i,j,k))*.5 + -.25*rdsi*( v(i,jp,kp)+v(i,jp,k )+v(i,j ,k )+v(i,j ,kp) ) + *(1-icylind) Compute the stress @ (i,j+1/2,k+1/2) diss=(eta(i,jp,kp)+eta(i,j,kp)+eta(i,jp,k)+eta(i,j,k))*.25 !kin. vis. gt23=( gmm(i,jp,kp)**2+gmm(i,j,kp)**2 + +gmm(i,jp,k )**2+gmm(i,j,k )**2 )*.25 e23(i,j,k)=2.*diss*e23(i,j,k)/gt23 !tau^23 e32(i,j,k)=e23(i,j,k) !tau^32 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23bz(i,j,kk)=2.*dissb*e23b/gt23b e32bz(i,j,kk)=e23bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23by(i,k,jj)=2.*dissb*e23b/gt23b e32by(i,k,jj)=e23by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23bx(j,k,ii)=2.*dissb*e23b/gt23b e32bx(j,k,ii)=e23bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif call update( e11,np,mp,l,np,mp,iup) call update( e12,np,mp,l,np,mp,iup) call updatelr(e13,np,mp,l,np,mp,iupx) call update( e21,np,mp,l,np,mp,iup) call update( e22,np,mp,l,np,mp,iup) call updatebt(e23,np,mp,l,np,mp,iupy) call update( e31,np,mp,l,np,mp,iup) call update( e32,np,mp,l,np,mp,iup) call update( e33,np,mp,l,np,mp,iup) c ---------------------------------------------------------c c End stress/strain rates computations c c ---------------------------------------------------------c if(tt.le.tend) call vstrhat(ox,oy,oz,-1) ! ret. contravariant vel. #if (TIMEPLT == 1) call ttend(41) #endif return end subroutine stressdv(fu,fv,fw,flx,fly,flz) C C *************************************************** c * computes rhs forcings due to stress divergence * C *************************************************** c c tij - contravariant stresses c fu, fv, fz - "xbar,ybar,zbar" components of stress c divergence; note they are divided by c density*Jacobian = rho(i,j,k) c C ******************************************* include 'param.nml' include 'msg.inc' dimension fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . flx(1-ih:np+ih, 1-ih:mp+ih, l), . fly(1-ih:np+ih, 1-ih:mp+ih, l), . flz(1-ih:np+ih, 1-ih:mp+ih, l) common/strainc/ t11(1-ih:np+ih,1-ih:mp+ih,L), * t12(1-ih:np+ih,1-ih:mp+ih,L), * t13(1-ih:np+ih,1-ih:mp+ih,L), * t21(1-ih:np+ih,1-ih:mp+ih,L), * t22(1-ih:np+ih,1-ih:mp+ih,L), * t23(1-ih:np+ih,1-ih:mp+ih,L), * t31(1-ih:np+ih,1-ih:mp+ih,L), * t32(1-ih:np+ih,1-ih:mp+ih,L), * t33(1-ih:np+ih,1-ih:mp+ih,L), * t11bx(mp,l,2),t11by(np,l,2),t11bz(np,mp,2), * t12bx(mp,l,2),t12by(np,l,2),t12bz(np,mp,2), * t13bx(mp,l,2),t13by(np,l,2),t13bz(np,mp,2), * t21bx(mp,l,2),t21by(np,l,2),t21bz(np,mp,2), * t22bx(mp,l,2),t22by(np,l,2),t22bz(np,mp,2), * t23bx(mp,l,2),t23by(np,l,2),t23bz(np,mp,2), * t31bx(mp,l,2),t31by(np,l,2),t31bz(np,mp,2), * t32bx(mp,l,2),t32by(np,l,2),t32bz(np,mp,2), * t33bx(mp,l,2),t33by(np,l,2),t33bz(np,mp,2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) ! size of regular array parameter(iarrx1=(np+1)*mp*l) ! size of fx parameter(iarry1=np*(mp+1)*l) ! size of fy parameter(iarrz1=np*mp*(l+1)) ! size of fz parameter(iaryb=np*l*2) ! size of flyb parameter(iarxb=mp*l*2) ! size of flxb parameter(iarzb=np*mp*2) ! size of flxb parameter(ifree=16*iarray-iarrx1-iarry1-iarrz1-iaryb-iarxb-iarzb) common/blank/ 2 flxb(mp,l,2),flyb(np,l,2),flzb(np,mp,2), 1 fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l),src(ifree) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz #if (TIMEPLT == 1) call ttbeg(42) #endif c ---------------------------------------------------------c c Compute "xbar,ybar,zbar" contributions to viscous c c fluxes in "x,y,z" directions; add them to form c c "x,y,z" viscous flux components; compute divergence c c including Christoffel terms. c c c c Note viscous stress is contravariant form ^ij c c c c Compute staggered values of fluxes centered at: c c flx -> i+1/2, fly -> j+1/2; flz -> k+1/2 c c whereas divergence and Christoffel terms are c c centered at (i,j,k) c c ---------------------------------------------------------c c --------------------------------------------------------- Compute the fu = tau^(1j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(1j) averaged @ (i+1/2,j,k) do j=1,mp jm=imm(j) do i=1,np ip=ipp(i) do k=1,L g110=.5*( gmm(ip,j,k)*cosa(ip,j)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*t11(i,j,k) . +g21*.5*(t12(i,j,k)+t12(i,jm,k)) flx(i,j,k)=0.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k)*g110 enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t11bx(j,k,ii)+g21b*t12bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii)*g110b enddo enddo endif enddo #endif c -----ybar contribution to tau^(1j) averaged @ (i,j+1/2,k) do j=1,mp jp=jpp(j) do i=1,np im=imm(i) do k=1,L g110=.5*( gmm(i,jp,k)*cosa(i,jp)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.25*( t11(i ,jp,k)+t11(i ,j,k) . +t11(im,jp,k)+t11(im,j,k) ) . +g22*.5*( t12(i ,j ,k)+t12(im,j,k)) fly(i,j,k)=0.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k)*g110 enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,l do i=1,np g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t11by(i,k,jj)+g22b*t12by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj)*g110b enddo enddo endif enddo #endif c -----zbar contribution to tau^(1j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g110=.5*( gmm(i,j,kp)*cosa(i,j)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g13= .5*( (s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*( (s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*( gi(i,j)*gmus(kp)+ gi(i,j) *gmus(k)) flz(i,j,k)= g13*.25*( t11(i ,j,kp)+t11(i , j, k) . +t11(im,j,kp)+t11(im, j, k) ) . +g23*.125*( t12(i, j, k)+t12(im, j, k) . +t12(i,jm, k)+t12(im,jm, k) . +t12(i, j,kp)+t12(im, j,kp) . +t12(i,jm,kp)+t12(im,jm,kp) ) . +g33*.5*(t13(i,j,k)+t13(im,j,k)) flz(i,j,k)=0.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k)*g110 enddo enddo enddo do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t11bz(i,j,kk)+g23b*t12bz(i,j,kk) . +g33b*t13bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk)*g110b enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute divergence: tau^(1j)_(,j) = fu @ (i,j,k) do k=2,L-1 ! interior points #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*.25* . (t31(i,j,k )+t31(i-1,j,k ) . +t31(i,j,k-1)+t31(i-1,j,k-1)) . -gmm(i,j,k)*sina(i,j)*.25* . ( t21(i,j ,k)+t21(i-1,j ,k) . +t21(i,j-j3,k)+t21(i-1,j-j3,k))) . *(1-icylind) . -icylind*0.5*rho(i,j,k)*gmm(i,j,k)*rdsi* . ( t22(i,j ,k)+ t22(i,j-j3 ,k) ) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31bx(j,k,ii) . -gmm(i,j,k)* sina(i,j)*t21bx(j,k,ii)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22bx(j,k,ii) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31by(i,k,jj) . -gmm(i,j,k)* sina(i,j)*t21by(i,k,jj)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22by(i,k,jj) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np fu(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31bz(i,j,kk) . -gmm(i,j,k)* sina(i,j)*t21bz(i,j,kk)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22bz(i,j,kk) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(1j)_(,j) completed c --------------------------------------------------------- Compute the fv = tau^(2j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(2j) averaged @ (i+1/2,j,k) do k=1,L do j=1,mp jm=jmm(j) do i=1,np ip=ipp(i) g220=.5*(gmm(ip,j,k)+gmm(i,j,k)) g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*.5*( t21(i ,j,k)+t21(i ,jm,k)) . +g21*.25*(t22(i ,j,k)+t22(i ,jm,k) . +t22(ip,j,k)+t22(ip,jm,k)) flx(i,j,k)=.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k)*g220 enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g220b=gmm(i,j,k) g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t21bx(j,k,ii)+g21b*t22bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii)*g220b enddo enddo endif enddo #endif c -----ybar contribution to tau^(2j) averaged @ (i,j+1/2,k) do k=1,L do j=1,mp jp=jpp(j) do i=1,np im=imm(i) g220=.5*(gmm(i,jp,k)+gmm(i,j,k)) g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.5*(t21(i,j,k)+t21(im,j,k)) . +g22* t22(i,j,k) fly(i,j,k)=.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k)*g220 enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np g220b=gmm(i,j,k) g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t21by(i,k,jj)+g22b*t22by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj)*g220b enddo enddo endif enddo #endif c -----zbar contribution to tau^(2j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g220=.5*(gmm(i,j,kp)+gmm(i,j,k)) g13= .5*((s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*((s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*( gi(i,j)*gmus(kp)+ gi(i,j) *gmus(k)) flz(i,j,k)= g13*.125*( t21(i ,j ,kp)+t21(i ,j ,k) . +t21(im,j ,kp)+t21(im,j ,k) . +t21(i ,jm,kp)+t21(i ,jm,k) . +t21(im,jm,kp)+t21(im,jm,k) ) . +g23*.25*(t22(i ,j ,kp)+t22(i ,j ,kp) . +t22(i ,jm,k )+t22(i ,jm,k) ) . +g33*.5*( t23(i ,j ,k )+t23(i ,jm,k)) flz(i,j,k)=.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k)*g220 enddo enddo enddo do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np g220b=gmm(i,j,k) g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t21bz(i,j,kk)+g23b*t22bz(i,j,kk) . +g33b*t23bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk)*g220b enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute divergence: tau^(2j)_(,j) = fv @ (i,j,k) do k=2,L-1 #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*( sina(i,j)*cosa(i,j)*gmm(i,j,k) . *.5*(t11(i,j,k )+t11(i-1,j,k)) . +.25*(t32(i,j,k )+t32(i,j-j3, k ) . +t32(i,j,k-1)+t32(i,j-j3,k-1) ) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.) . *.25*(t12(i,j,k )+t12(i-1,j, k ) . +t12(i,j-j3,k)+t12(i-1,j-j3,k) ) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32bx(j,k,ii) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11bx(j,k,ii) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12bx(j,k,ii) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32by(i,k,jj) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11by(i,k,jj) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12by(i,k,jj) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32bz(i,j,kk) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11bz(i,j,kk) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12bz(i,j,kk) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(2j)_(,j) completed c --------------------------------------------------------- Compute the fw = tau^(3j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(3j)_(,j) averaged @ (i+1/2,j,k) do k=1,L km=kmm(k) do j=1,mp jm=jmm(j) do i=1,np ip=ipp(i) g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*.5*( t31(i ,j, k)+t31(i ,j ,km)) . +g21*.125*( t32(i ,j, k)+t32(i ,jm,k ) . +t32(ip,j, k)+t32(ip,jm,k ) . +t32(i ,j,km)+t32(i ,jm,km) . +t32(ip,j,km)+t32(ip,jm,km)) flx(i,j,k)=0.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t31bx(j,k,ii)+g21b*t32bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii) enddo enddo endif enddo #endif c -----ybar contribution to tau^(3j) averaged @ (i,j+1/2,k) do k=1,L km=kmm(k) do j=1,mp jp=jpp(j) do i=1,np im=imm(i) g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.125*( t31(i,j ,k )+t31(im,j ,k ) . +t31(i,j ,km)+t31(im,j ,km) . +t31(i,jp,k )+t31(im,jp,k ) . +t31(i,jp,km)+t31(im,jp,km) ) . +g22*0.5*( t32(i,j ,k )+t32(i ,j ,km)) fly(i,j,k)=0.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k) enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t31by(i,k,jj)+g22b*t32by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj) enddo enddo endif enddo #endif c -----zbar contribution to tau^(3j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g13= .5*( (s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*( (s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*(gi(i,j)*gmus(kp)+gi(i,j)*gmus(k)) flz(i,j,k)= g13*.5*(t31(i,j,k)+t31(im,j,k)) . +g23*.5*(t32(i,j,k)+t32(i,jm,k)) . +g33*t33(i,j,k) flz(i,j,k)=0.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k) enddo enddo enddo do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t31bz(i,j,kk)+g23b*t32bz(i,j,kk) . +g33b*t33bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk) enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute tau^(3j)_(,j) = fw @ (i,j,k) do k=2,L-1 #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k)*( . cosa(i,j)**2*.5*(t11(i,j,k)+t11(i-1, j,k)) . +.5*(t22(i,j,k)+t22(i,j-j3,k)) ) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11bx(j,k,ii)+t22bx(j,k,ii)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11by(i,k,jj)+t22by(i,k,jj)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11bz(i,j,kk)+t22bz(i,j,kk)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(3j)_(,j) completed c --------------------------------------------------------c c End of computation of stress divergence c c --------------------------------------------------------c c enforce cyclicity #if (POLES == 0) if(ibcx.eq.1) then call updatelr(fu,np,mp,l,np,mp,1) call updatelr(fv,np,mp,l,np,mp,1) call updatelr(fw,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp fu(np,j,k)=fu(np+1,j,k) fv(np,j,k)=fv(np+1,j,k) fw(np,j,k)=fw(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(fu,np,mp,l,np,mp,1) call updatebt(fv,np,mp,l,np,mp,1) call updatebt(fw,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np fu(i,mp,k)=fu(i,mp+j3,k) fv(i,mp,k)=fv(i,mp+j3,k) fw(i,mp,k)=fw(i,mp+j3,k) enddo enddo endif endif #endif if(ibcz.eq.1) then do j=1,mp do i=1,np fu(i,j,l)=fu(i,j,1) fv(i,j,l)=fv(i,j,1) fw(i,j,l)=fw(i,j,1) enddo enddo endif #if (TIMEPLT == 1) call ttend(42) #endif return end subroutine inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) include 'param.nml' include 'msg.inc' dimension flx(1-ih:np+ih, 1-ih:mp+ih, l), . fly(1-ih:np+ih, 1-ih:mp+ih, l), . flz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l), 2 flxb(mp,l,2),flyb(np,l,2),flzb(np,mp,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(43) #endif call updatelr(flx,np,mp,l,np,mp,iupx) call updatebt(fly,np,mp,l,np,mp,iupy) do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif fx(i,j,k)=flx(i,j,k) ! flx must be updated enddo enddo enddo #if (POLES == 0) c----------> BC for xbar component of FX flux if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp fx(0,j,k)=flx(-1,j,k) ! fx(n-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp fx(np,j,k)=flx(np+2,j,k) ! fx( 1 ,j,k) enddo enddo endif else do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np ! 1 or 2 is=(i-1)/(np-1)*np ! 0 or n ik=((np-2)*i+1)/(np-1) ! 1 or n-1 do k=1,l do j=1,mp fx(is,j,k)=2.*flxb(j,k,ii)-fx(ik,j,k) enddo enddo endif enddo endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np fy(i,j,k)=fly(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for ybar component of FY flux if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,l do i=1,np fy(i,0,k)=fly(i,-1,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=1,np fy(i,mp,k)=fly(i,mp+2,k) enddo enddo endif else do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp ! 1 or 2 js=(j-j3)/(mp-j3)*mp ! 0 or m jk=((mp-1-j3)*j+1)/(mp-j3) ! 1 or m-1 do k=1,l do i=1,np fy(i,js,k)=2.*flyb(i,k,jj)-fy(i,jk,k) enddo enddo endif enddo endif #endif do k=1,L-1 do j=1,mp do i=1,np fz(i,j,k)=flz(i,j,k) enddo enddo enddo c----------> BC for zbar component of FZ flux if(ibcz.eq.1) then do j=1,mp do i=1,np fz(i,j,0)=fz(i,j,l-1) fz(i,j,l)=fz(i,j, 1 ) enddo enddo else do k=1,l,l-1 kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) do j=1,mp do i=1,np fz(i,j,ks)=2.*flzb(i,j,kk)-fz(i,j,ki) enddo enddo enddo endif #if (TIMEPLT == 1) call ttend(43) #endif return end subroutine normalv C ******************************************* c c computes components of domain boundary unit normals in both c physical coordinates (pnx, pny, pnz) and transformed coordinates c (tnsx, tnsy, tnxz) where s=x,y,z corresponds to i=1,n; j=1,m; and c k=1,l surfaces; respectively. Only components in transformed c coordinates are passed out of subroutine. c c NOTES: c (i) in either coordinate system, same unit normal vector is c being computed, but component description is coordinate dependent. c (ii) direction of normals is along principle coordinate direction c used to define boundary; eg., into domain for lower, left, and c front boundaries, and out of domain for upper, right, and back c boundaries. c C ******************************************* include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) #if (TIMEPLT == 1) call ttbeg(44) #endif #if (POLES == 0) c-------> transformed components of the normal to i=1,n surfaces c (NOTE: boundary is defined not a function of z) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,l do j=1,mp cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gnr=sqrt(1.+strxy(i,j)**2) pnx=1./gnr pny=strxy(i,j)*pnx tnxx(j,k,ii)=pnx*strxx(i,j)+pny*strxy(i,j) tnxy(j,k,ii)=pnx*stryx(i,j)+pny*stryy(i,j) tnxz(j,k,ii)=pnx*cx+pny*cy enddo enddo endif enddo c-------> transformed components of the normal to j=1,m surfaces c (NOTE: boundary is defined not a function of z) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,l do i=1,np cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gnr=sqrt(stryx(i,j)**2+1.) pny=1./gnr pnx=stryx(i,j)*pny tnyx(i,k,jj)=pnx*strxx(i,j)+pny*strxy(i,j) tnyy(i,k,jj)=pnx*stryx(i,j)+pny*stryy(i,j) tnyz(i,k,jj)=pnx*cx+pny*cy enddo enddo endif enddo #endif c-------> transformed components of the normal to k=1,l surfaces do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) cz=gmus(k)*gi(i,j) zsx=-cx/cz zsy=-cy/cz gnr=sqrt(1.+zsx**2+zsy**2) pnz= 1./gnr pnx=-zsx*pnz pny=-zsy*pnz tnzx(i,j,kk)=pnx*strxx(i,j)+pny*strxy(i,j) tnzy(i,j,kk)=pnx*stryx(i,j)+pny*stryy(i,j) tnzz(i,j,kk)=pnx*cx+pny*cy+pnz*cz enddo enddo enddo #if (TIMEPLT == 1) call ttend(44) #endif return end subroutine fckflxdv(p,fp,eta,f1,f2,f3,sfflx,sffly,sfflz) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fp(1-ih:np+ih,1-ih:mp+ih,l), . f1(1-ih:np+ih,1-ih:mp+ih,l), . f2(1-ih:np+ih,1-ih:mp+ih,l), . f3(1-ih:np+ih,1-ih:mp+ih,l), . sfflx(mp,l,2), . sffly(np,l,2), . sfflz(np,mp,2), . eta(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) common/sgscnst/ ceps,cL,cm,css,prndt common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/diffus/ sk(l),skr(l),sls parameter(iarray=(np+2*ih)*(mp+2*ih)*l) ! size of regular array parameter(iarrpz=(np+2*ih)*(mp+2*ih)*(l+1)) ! size of pz parameter(iarrx1=(np+1)*mp*l) ! size of fx parameter(iarry1=np*(mp+1)*l) ! size of fy parameter(iarrz1=np*mp*(l+1)) ! size of fz parameter(iarret=np*mp*l) ! size of etai parameter(ifree=13*iarray-iarrpz-iarrx1-iarry1-iarrz1-iarret) common/blank/ px(1-ih:np+ih,1-ih:mp+ih,l), . py(1-ih:np+ih,1-ih:mp+ih,l), . pz(1-ih:np+ih,1-ih:mp+ih,0:l), 1 dvf(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l), 1 etai(np,mp,l),src(ifree) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz #if (TIMEPLT == 1) call ttbeg(45) #endif compute some local constants ep=1.e-10 pi=acos(-1.) call update(p,np,mp,l,np,mp,iup) ! p=th in anelas do k=1,l do j=1,mp do i=1,np etai(i,j,k)=1./amax1(eta(i,j,k),ep) enddo enddo enddo do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif px(i,j,k)= dxi*(p(i+1,j,k)-p(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,L do j=1,mp px(0,j,k)= dxi*(p(1,j,k)-p(-1,j,k)) ! px(0,j,k)= px(n-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp px(np,j,k)= dxi*(p(np+2,j,k)-p(np,j,k)) ! px(n,j,k)= px(1,j,k) enddo enddo endif endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np py(i,j,k)= dyi*(p(i,j+j3,k)-p(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,L do i=1,np py(i,0,k)= dyi*(p(i,1,k)-p(i,1-2*j3,k)) ! py(i,0,k)= py(i,m-j3,k) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np py(i,mp,k)= dyi*(p(i,mp+2*j3,k)-p(i,mp,k)) ! py(i,m,k)= py(i,1,k) enddo enddo endif endif #endif do k=1,L-1 do j=1,mp do i=1,np pz(i,j,k)= dzi*(p(i,j,k+1)-p(i,j,k)) enddo enddo enddo if(ibcz.eq.1) then do j=1,mp do i=1,np pz(i,j,0)= pz(i,j,l-1) pz(i,j,l)= pz(i,j, 1 ) enddo enddo endif c-------------------------------- #if (POLES == 0) if(ibcx.eq.0) then do 1 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) do 10 k=2-ibcz,l-1+ibcz do 10 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge cfx= 1./tnxx(j,k,ii) cfy=tnxy(j,k,ii)/tnxx(j,k,ii) cfz=tnxz(j,k,ii)/tnxx(j,k,ii) px0=-cfx*sfflx(j,k,ii)*etai(i,j,k) + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 + -cfz*(pz(i,j,k)+pz(i, j,k-1))*0.5 px(is,j,k)=2.*px0-px(ik,j,k) 10 continue if(ibcz.eq.0) then do 11 k=1,l,l-1 kk=1+k/l do 111 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge qx=sfflx(j,k,ii)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnxx(j,k,ii)*tnzz(i,j,kk)-tnxz(j,k,ii)*tnzx(i,j,kk) ed1=(tnzz(i,j,kk)*qx-tnxz(j,k,ii)*qz)/dn ed2=( tnxy(j,k,ii)*tnzz(i,j,kk) + -tnxz(j,k,ii)*tnzy(i,j,kk) )/dn px0=-ed1-ed2*(py(i,j,k)+py(i,j-j3,k))*0.5 111 px(is,j,k)=2.*px0-px(ik,j,k) if(ibcy.eq.0.and.j3.eq.1) then do 112 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d1=- qx*tnyy(i,k,jj)*tnzz(i,j,kk) . -tnxy(j,k,ii)*tnyz(i,k,jj)*qz . -tnxz(j,k,ii)* qy*tnzy(i,j,kk) . +tnxz(j,k,ii)*tnyy(i,k,jj)*qz . + qx*tnyz(i,k,jj)*tnzy(i,j,kk) . +tnxy(j,k,ii)* qy*tnzz(i,j,kk) px0=d1/dn endif ! bot or top edges 112 px(is,j,k)=2.*px0-px(ik,j,k) endif ! ibcy=0 & j3=1 11 continue endif ! ibcz=0 if(ibcy.eq.0) then do 12 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do 121 k=2,l-1 qy=sffly(i,k,jj)*etai(i,j,k) qx=sfflx(j,k,ii)*etai(i,j,k) dn=tnxx(j,k,ii)*tnyy(i,k,jj)-tnxy(j,k,ii)*tnyx(i,k,jj) ed1=(tnyy(i,k,jj)*qx-tnxy(j,k,ii)*qy)/dn ed2=( tnxz(j,k,ii)*tnyy(i,k,jj) + -tnxy(j,k,ii)*tnyz(i,k,jj) )/dn px0=-ed1-ed2*(pz(i,j,k)+pz(i,j,k-1))*0.5 121 px(is,j,k)=2.*px0-px(ik,j,k) endif ! bot or top edges 12 continue endif ! ibcy=0 endif ! left or right edges 1 continue endif ! ibcx=0 #endif c-------------------------------- #if (POLES == 0) if(ibcy.eq.0) then do 2 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) do 20 k=2-ibcz,l-1+ibcz do 20 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge cfy= 1./tnyy(i,k,jj) cfx=tnyx(i,k,jj)/tnyy(i,k,jj) cfz=tnyz(i,k,jj)/tnyy(i,k,jj) py0=-cfy*sffly(i,k,jj)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1,j,k))*0.5 + -cfz*(pz(i,j,k)+pz(i,j,k-1))*0.5 20 py(i,js,k)=2.*py0-py(i,jk,k) if(ibcx.eq.0) then do 21 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do 211 k=2-ibcz,l-1+ibcz qx=sfflx(j,k,ii)*etai(i,j,k) qy=sffly(i,k,jj)*etai(i,j,k) dn=tnxx(j,k,ii)*tnyy(i,k,jj)-tnxy(j,k,ii)*tnyx(i,k,jj) ed1=(tnxx(j,k,ii)*qy-tnyx(i,k,jj)*qx)/dn ed2=( tnxx(j,k,ii)*tnyz(i,k,jj) + -tnxz(j,k,ii)*tnyx(i,k,jj) )/dn py0=-ed1-ed2*(pz(i,j,k)+pz(i,j,k-1))*0.5 211 py(i,js,k)=2.*py0-py(i,jk,k) if(ibcz.eq.0) then do 212 k=1,l,l-1 kk=1+k/l qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d2=-tnxx(j,k,ii)* qy*tnzz(i,j,kk) . - qx*tnyz(i,k,jj)*tnzx(i,j,kk) . -tnxz(j,k,ii)*tnyx(i,k,jj)*qz . +tnxz(j,k,ii)* qy*tnzx(i,j,kk) . +tnxx(j,k,ii)*tnyz(i,k,jj)*qz . + qx*tnyx(i,k,jj)*tnzz(i,j,kk) py0=d2/dn 212 py(i,js,k)=2.*py0-py(i,jk,k) endif endif ! left or right edges 21 continue endif ! ibcy=0 if(ibcz.eq.0) then do 22 k=1,l,l-1 kk=1+k/l do 221 i=1+leftedge,np-rightedge qy=sffly(i,k,jj)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnyy(i,k,jj)*tnzz(i,j,kk)-tnyz(i,k,jj)*tnzy(i,j,kk) ed1=(tnzz(i,j,kk)*qy-tnyz(i,k,jj)*qz)/dn ed2=( tnyx(i,k,jj)*tnzz(i,j,kk) + -tnyz(i,k,jj)*tnzx(i,j,kk) )/dn py0=-ed1-ed2*(px(i,j,k)+px(i-1,j,k))*0.5 221 py(i,js,k)=2.*py0-py(i,jk,k) 22 continue endif ! ibcz=0 endif ! bot or top edges 2 continue endif ! ibcy=0 #endif c-------------------------------- if(ibcz.eq.0) then do 3 k=1,l,l-1 kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) #if (POLES == 0) do 30 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge do 30 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge #else do 30 j=1,mp do 30 i=1,np #endif cfz= 1./tnzz(i,j,kk) cfx=tnzx(i,j,kk)/tnzz(i,j,kk) cfy=tnzy(i,j,kk)/tnzz(i,j,kk) pz0=-cfz*sfflz(i,j,kk)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1, j,k))*0.5 + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 30 continue #if (POLES == 0) if(ibcx.eq.0) then do 31 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do 311 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge qx=sfflx(j,k,ii)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnxx(j,k,ii)*tnzz(i,j,kk)-tnxz(j,k,ii)*tnzx(i,j,kk) ed1=(tnxx(j,k,ii)*qz-tnzx(i,j,kk)*qx)/dn ed2=( tnxx(j,k,ii)*tnzy(i,j,kk) + -tnxy(j,k,ii)*tnzx(i,j,kk) )/dn pz0=-ed1-ed2*(py(i,j,k)+py(i,j-j3,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 311 continue if(ibcy.eq.0.and.j3.eq.1) then do 312 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d3=-tnxx(j,k,ii)*tnyy(i,k,jj)*qz . -tnxy(j,k,ii)* qy*tnzx(i,j,kk) . - qx*tnyx(i,k,jj)*tnzy(i,j,kk) . + qx*tnyy(i,k,jj)*tnzx(i,j,kk) . +tnxx(j,k,ii)* qy*tnzy(i,j,kk) . +tnxy(j,k,ii)*tnyx(i,k,jj)*qz pz0=d3/dn pz(i,j,ks)=2.*pz0-pz(i,j,ki) endif ! bot or top edges 312 continue endif ! ibcy=0 & j3=1 endif ! left or right edges 31 continue endif ! ibcx=0 if(ibcy.eq.0) then do 32 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do 321 i=1+leftedge,np-rightedge qy=sffly(i,k,jj)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnyy(i,k,jj)*tnzz(i,j,kk)-tnyz(i,k,jj)*tnzy(i,j,kk) ed1=(tnyy(i,k,jj)*qz-tnzy(i,j,kk)*qy)/dn ed2=(tnyy(i,k,jj)*tnzx(i,j,kk) + -tnyx(i,k,jj)*tnzy(i,j,kk) )/dn pz0=-ed1-ed2*(px(i,j,k)+px(i-1,j,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 321 continue endif ! bot or top edges 32 continue endif ! ibcy=0 #endif 3 continue endif ! ibcz=0 call updatebtw(px,0,np,1,mp,l,1,np,1,mp,iupy) call updatelrw(py,1,np,0,mp,l,1,np,1,mp,iupx) call update2(pz,np,mp,l+1,np,mp,iup) c------------> xbar component of Fickian flux at i+1/2 #if (POLES == 0) DO I=1,NP-rightedge #else DO I=1,NP #endif ip=i+1 DO K=1,L DO J=1,MP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(ip,j,k)*cosa(ip,j)+icylind*1.) g220p=1./gmm(ip,j,k) g11p=strxx(ip,j)*g110 g12p=stryx(ip,j)*g110 g13p=(s13(ip,j)*gmul(k)-h13(ip,j))*gmus(k)*g110 g21p=strxy(ip,j)*g220 g22p=stryy(ip,j)*g220 g23p=(s23(ip,j)*gmul(k)-h23(ip,j))*gmus(k)*g220 g33p=gi(ip,j)*gmus(k) gf11=.5*( ( g11p**2 + g21p**2 ) . +( g11**2 + g21**2 ) ) gf12=.5*( ( g11p*g12p + g21p*g22p ) . +( g11*g12 + g21*g22 ) ) gf13=.5*( ( g11p*g13p + g21p*g23p ) . +( g11*g13 + g21*g23 ) ) f1(i,j,k)=gf11*px(i,j,k) + +gf12*( py(ip,j,k)+py(ip,j-j3,k) + +py( i,j,k)+py( i,j-j3,k) )*.25 + +gf13*( pz(ip,j,k)+pz(ip, j,k-1) + +pz( i,j,k)+pz( i, j,k-1) )*.25 diss=(eta(ip,j,k)+eta(i,j,k))*.5 ! kinematic viscosity diss=diss*(rho(ip,j,k)+rho(i,j,k))*.5 ! dynamic viscosity f1(i,j,k)=diss*f1(i,j,k) ENDDO ENDDO ENDDO c------------> ybar component of Fickian flux at j+1/2 #if (POLES == 0) DO 5 J=1,MP-j3*topedge #else DO 5 J=1,MP #endif jp=j+j3 DO K=1,L DO I=1,NP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(i,jp,k)*cosa(i,jp)+icylind*1.) g220p=1./gmm(i,jp,k) g11p=strxx(i,jp)*g110 g12p=stryx(i,jp)*g110 g13p=(s13(i,jp)*gmul(k)-h13(i,jp))*gmus(k)*g110 g21p=strxy(i,jp)*g220 g22p=stryy(i,jp)*g220 g23p=(s23(i,jp)*gmul(k)-h23(i,jp))*gmus(k)*g220 g33p=gi(i,jp)*gmus(k) gf21=.5*( ( g11p*g12p + g21p*g22p ) . +( g11*g12 + g21*g22 ) ) gf22=.5*( ( g12p**2 + g22p**2 ) . +( g12**2 + g22**2 ) ) gf23=.5*( ( g12p*g13p + g22p*g23p ) . +( g12*g13 + g22*g23 ) ) f2(i,j,k)=gf21*( px(i,jp,k)+px(i-1,jp,k) + +px(i,j ,k)+px(i-1,j ,k) )*.25 + +gf22* py(i,j ,k) + +gf23*( pz(i,jp,k)+pz(i,jp,k-1) + +pz(i, j,k)+pz(i, j,k-1) )*.25 diss=(eta(i,jp,k)+eta(i,j,k))*.5 ! kinematic viscosity diss=diss*(rho(i,jp,k)+rho(i,j,k))*.5 ! dynamic viscosity f2(i,j,k)=diss*f2(i,j,k) ENDDO ENDDO 5 CONTINUE c------------> zbar component of Fickian flux at k+1/2 DO 6 K=1,L-1 kp=k+1 DO J=1,MP DO I=1,NP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(i,j,kp)*cosa(i,j)+icylind*1.) g220p=1./gmm(i,j,kp) g11p=strxx(i,j)*g110 g12p=stryx(i,j)*g110 g13p=(s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp)*g110 g21p=strxy(i,j)*g220 g22p=stryy(i,j)*g220 g23p=(s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp)*g220 g33p=gi(i,j)*gmus(kp) gf31=.5*( ( g11p*g13p + g21p*g23p ) . +( g11*g13 + g21*g23 ) ) gf32=.5*( ( g12p*g13p + g22p*g23p ) . +( g12*g13 + g22*g23 ) ) gf33=.5*( ( g13p**2 + g23p**2 + g33p**2 ) . +( g13**2 + g23**2 + g33**2 ) ) f3(i,j,k)=gf31*( px(i,j,kp)+px(i-1, j,kp) + +px(i,j,k )+px(i-1, j,k ) )*.25 + +gf32*( py(i,j,kp)+py(i,j-j3,kp) + +py(i,j,k )+py(i,j-j3,k ) )*.25 + +gf33*pz(i,j,k) diss=(eta(i,j,kp)+eta(i,j,k))*.5 ! kinematic viscosity c diss=(eta(i,j,kp)*gmm(i,j,kp)**2+eta(i,j,k)*gmm(i,j,k)**2)*.5 ! ki vis diss=diss*(rho(i,j,kp)+rho(i,j,k))*.5 ! dynamic viscosity f3(i,j,k)=diss*f3(i,j,k) ENDDO ENDDO 6 CONTINUE call updatelr(f1,np,mp,l,np,mp,iupx) call updatebt(f2,np,mp,l,np,mp,iupy) do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif fx(i,j,k)=f1(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for xbar component of Fickian flux if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp fx(0,j,k)=f1(-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp fx(np,j,k)=f1(np+2,j,k) enddo enddo endif else do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) do k=1,l do j=1,mp cfx= 1./tnxx(j,k,ii) cfy=tnxy(j,k,ii)/tnxx(j,k,ii) cfz=tnxz(j,k,ii)/tnxx(j,k,ii) px0=-cfx*sfflx(j,k,ii)*etai(i,j,k) + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 + -cfz*(pz(i,j,k)+pz(i, j,k-1))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf11= g11**2 + g21**2 gf12= g11*g12 + g21*g22 gf13= g11*g13 + g21*g23 fx0= gf11*px0 + +gf12*( py(i,j,k)+py(i,j-j3,k) )*0.5 + +gf13*( pz(i,j,k)+pz(i, j,k-1) )*0.5 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fx0=diss*fx0 fx(is,j,k)=2.*fx0-fx(ik,j,k) enddo enddo endif enddo endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np fy(i,j,k)=f2(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for ybar component of Fickian flux if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,l do i=1,np fy(i,0,k)=f2(i,1-2*j3,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=1,np fy(i,mp,k)=f2(i,mp+2*j3,k) enddo enddo endif else do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) do k=1,l do i=1,np cfx=tnyx(i,k,jj)/tnyy(i,k,jj) cfy=1./tnyy(i,k,jj) cfz=tnyz(i,k,jj)/tnyy(i,k,jj) py0=-cfy*sffly(i,k,jj)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1,j,k))*0.5 + -cfz*(pz(i,j,k)+pz(i,j,k-1))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf21= g11*g12 + g21*g22 gf22= g12**2 + g22**2 gf23= g12*g13 + g22*g23 fy0=gf21*( px(i,j,k)+px(i-1,j,k) )*0.5 + +gf22*py0 + +gf23*( pz(i,j,k)+pz(i,j,k-1) )*0.5 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fy0=diss*fy0 fy(i,js,k)=2.*fy0-fy(i,jk,k) enddo enddo endif enddo endif #endif do k=1,L-1 do j=1,mp do i=1,np fz(i,j,k)=f3(i,j,k) enddo enddo enddo c----------> BC for zbar component of Fickian flux if(ibcz.eq.1) then do j=1,mp do i=1,np fz(i,j,0)=fz(i,j,l-1) fz(i,j,l)=fz(i,j, 1 ) enddo enddo else do k=1,l,l-1 ! =1 or =l kk=1+k/l ! =1 =2 ks=(k-1)/(l-1)*l ! =0 =l ki=((l-2)*k+1)/(l-1) ! =1 =l-1 do j=1,mp do i=1,np cfz= 1./tnzz(i,j,kk) cfx=tnzx(i,j,kk)/tnzz(i,j,kk) cfy=tnzy(i,j,kk)/tnzz(i,j,kk) pz0=-cfz*sfflz(i,j,kk)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1, j,k))*0.5 + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf31= g11*g13 + g21*g23 gf32= g12*g13 + g22*g23 gf33= g13**2 + g23**2 + g33**2 fz0= gf31*( px(i,j,k)+px(i-1, j,k) )*0.5 + +gf32*( py(i,j,k)+py(i,j-j3,k) )*0.5 + +gf33*pz0 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fz0=diss*fz0 fz(i,j,ks)= 2.*fz0-fz(i,j,ki) c if(k.eq.l) fz(i,j,ks)=fz(i,j,ki) enddo enddo enddo endif c----------> divergence of Fickian fluxes do k=1,L do j=1,mp do i=1,np dvf(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1,j,k)) . +dyi*(fy(i,j,k)-fy(i,j-1,k)) . +dzi*(fz(i,j,k)-fz(i,j,k-1)) ) enddo enddo enddo c enforce cyclicity if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if (iencyc.eq.1) then if(ibcx.eq.1) then call updatelr(dvf,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp dvf(np,j,k)=dvf(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(dvf,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np dvf(i,mp,k)=dvf(i,mp+j3,k) enddo enddo endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np dvf(i,j,l)=dvf(i,j,1) enddo enddo endif endif do k=1,L do j=1,mp do i=1,np fp(i,j,k) = dvf(i,j,k)*rhoi(i,j,k) c fp(i,j,k)= fp(i,j,k)+2.*dvf(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(45) #endif return end subroutine indexdef include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz c DO k=1,L kmm(k)=ibcz*(k-1+(l+1-k)/l*(l-1))+iboz*max0(k-1,1) kpp(k)=ibcz*(k+1 -k /l*(l-1))+iboz*min0(k+1,l) ENDDO #if (POLES == 0) DO j=1,MP C jm=ibcy*(j-j3+(m+j3-j)/m*(m-1))+(1-ibcy)*max0(j-j3,1) C jp=ibcy*(j+j3 -j /m*(m-1))+(1-ibcy)*min0(j+j3,m) if (botedge.eq.1 .and. j.eq.1) then jmm(j)=ibcy*(1-2*j3)+iboy else jmm(j)=j-1 end if if (topedge.eq.1 .and. j.eq.mp) then jpp(j)=ibcy*(mp+2*j3)+iboy*mp else jpp(j)=j+1 end if ENDDO DO i=1,NP C im=ibcx*(i-1+(n+1-i)/n*(n-1))+(1-ibcx)*max0(i-1,1) C ip=ibcx*(i+1 -i /n*(n-1))+(1-ibcx)*min0(i+1,n) if (leftedge.eq.1 .and. i.eq.1) then imm(i)=ibcx*(-1)+ibox else imm(i)=i-1 end if if (rightedge.eq.1 .and. i.eq.np) then ipp(i)=ibcx*(np+2)+ibox*np else ipp(i)=i+1 end if ENDDO #else DO j=1,MP jmm(j)=j-1 jpp(j)=j+1 ENDDO DO i=1,NP imm(i)=i-1 ipp(i)=i+1 ENDDO #endif return end #endif /* endif SGS == 2 */ #endif /* endif ANALIZE == 0 */ subroutine lapdf(p,r,c,Prinv,hx,hy,hz,pz,itf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . r(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), 2 hz(1-ih:np+ih, 1-ih:mp+ih, l), 1 Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1), . srff(1-ih:np+ih, 1-ih:mp+ih) ! ! Subroutine calculates diffusion terms, ! input fields: p-scalar field, c-eddy diffusivity, ! the output diffusion term is in matrix: r. ! Note that this subroutine is called only when ivisc=1. ! hy,hz are work arrays !--------------------------------------------------------------------- common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/stresd/ diagstr(8),ivis,irid,itstr common/sgscnst/ ceps,cL,cm,cs,prndt common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(48) #endif hdxi=0.5*dxi hdyi=0.5*dyi hdzi=0.5*dzi pri=1./prndt if(itf.eq.0) pri=1. compute z-derivatives at (i,j,k+-1/2) call update(p,np,mp,l,np,mp,iup) do k=2,L do j=1,mp do i=1,np pz(i,j,k)=dzi*(p(i,j,k)-p(i,j,k-1)) end do end do end do IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np pz(i,j,L+1)=-pz(i,j,L) end do end do corporate surface fluxes for theta, qv, and everything else(=0 flux) if (itf.eq.1) then ! temperature, do j=1,mp do i=1,np srff(i,j)=hfx(i,j) enddo enddo else if (itf.eq.-1) then ! moisture, do j=1,mmsp do i=1,nmsp srff(i,j)=qfx(i,j) enddo enddo else do j=1,mp do i=1,np srff(i,j)=0. enddo enddo endif do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 srff(i,j) = sqrt(g33)*srff(i,j)/amax1(pri*c(i,j,1),1.e-10) enddo enddo #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 21 j=jllim,julim #if (POLES == 0) if (j3.eq.1) then if (topedge.eq.1 .and. j.eq.mp) then jp1 = mp + 2 else jp1 = j + 1 end if if (botedge.eq.1 .and. j.eq.1) then jm1 = -1 else jm1 = j - 1 end if else jp1=1 jm1=1 end if cvec jp1=j+j3-j/m*(m-1) cvec jm1=j-j3+(m-j)/(m-j3)*(m-j3) #else jp1 = j + 1 jm1 = j - 1 #endif do 21 i=illim,iulim #if (POLES == 0) if (rightedge.eq.1 .and. i.eq.np) then ip1 = np + 2 else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then im1 = -1 else im1 = i - 1 end if cvec ip1=i+1-i/n*(n-1) cvec im1=i-1+(n-i)/(n-1)*(n-1) #else ip1 = i + 1 im1 = i - 1 #endif G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) px=hdxi*(p(ip1,j,1)-p(im1,j,1)) py=hdyi*(p(i,jp1,1)-p(i,jm1,1))*j3 21 pz(i,j,1)=-2.*(srff(i,j)+g13*px+g23*py)/g33-pz(i,j,2) #if (POLES == 0) if(ibcx.eq.0) then illim = leftedge + np*(1-leftedge) iulim = np*rightedge + 1*(1-rightedge) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge do 211 i=illim,iulim,np-1 do 2111 j=jllim,julim if (j3.eq.1) then if (topedge.eq.1 .and. j.eq.mp) then jp1 = mp + 2 else jp1 = j + 1 end if if (botedge.eq.1 .and. j.eq.1) then jm1 = -1 else jm1 = j - 1 end if else jp1=1 jm1=1 end if cvec jp1=j+j3-j/m*(m-1) cvec jm1=j-j3+(m-j)/(m-j3)*(m-j3) G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) py=hdyi*(p(i,jp1,1)-p(i,jm1,1))*j3 2111 pz(i,j,1)=-2.*(srff(i,j)+g23*py)/(g33-g13*g13)-pz(i,j,2) if(ibcy.eq.0.and.j3.eq.1) then jllim = 1*botedge + mp*(1-botedge) julim = mp*topedge + 1*(1-topedge) do 2112 j=jllim,julim,mp-j3 2112 pz(i,j,1)=-2.*srff(i,j)/(gi(i,j)**2*Prinv(i,j,1))-pz(i,j,2) endif 211 continue endif if(ibcy.eq.0.and.j3.eq.1) then jllim = 1*botedge + mp*(1-botedge) julim = mp*topedge + 1*(1-topedge) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge do 212 j=jllim,julim,mp-j3 do 2121 i=illim,iulim if (rightedge.eq.1 .and. i.eq.np) then ip1 = np + 2 else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then im1 = -1 else im1 = i - 1 end if cvec ip1=i+1-i/n*(n-1) cvec im1=i-1+(n-i)/(n-1)*(n-1) G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) px=hdxi*(p(ip1,j,1)-p(im1,j,1)) 2121 pz(i,j,1)=-2.*(srff(i,j)+g13*px)/(g33-g23*g23)-pz(i,j,2) 212 continue endif #endif ELSE do j=1,mp do i=1,np pz(i,j,L+1)=pz(i,j,2) pz(i,j, 1 )=pz(i,j,L) end do end do ENDIF call update(c,np,mp,l,np,mp,1) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pz,np,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pz,np+1,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pz,np,mp+1,l+1,np+1,mp+1,1) else call update(pz,np+1,mp+1,l+1,np+1,mp+1,1) end if compute x-flux at (i+-1/2,j,k) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G11m=1./((1-icylind)*gmm(i-1,j,k)*cosa(i,j)+icylind*1.) G11a=0.5*(G110+G11m) g13=0.5*gmul(k)*(G11m*s13(i-1,j)+G110*s13(i,j)) pza=0.25*(pz(i-1,j,k)+pz(i,j,k)+pz(i-1,j,k+1)+pz(i,j,k+1)) coef=0.25*pri*(c(i-1,j,k)+c(i,j,k)) . *(rho(i-1,j,k)+rho(i,j,k)) Pxa=dxi*(p(i,j,k)-p(i-1,j,k)) hx(i,j,k)=( G11a*pxa + g13*pza )*coef end do end do end do #if (POLES == 0) create boundary conditions at i=1 if(ibcx.eq.1) call updatelr(hx,np,mp,l,np,mp,1) if (leftedge.eq.1) then do j=1,mp do k=1,l cdel hx(1,j,k) = (ibcx-1)*hx(2,j,k) + ibcx*hx(0,j,k) hx(1,j,k) = hx(2,j,k) end do end do end if #endif c compute y-flux at (i,j+-1/2,k) if (j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp #endif do k=1,l do j=jllim,julim do i=1,np G220=1./gmm(i,j,k) G22m=1./gmm(i,j-1,k) G22a=0.5*(G220+G22m) g23=0.5*gmul(k)*(G22m*s23(i,j-j3)+G220*s23(i,j)) pza=0.25*( pz(i,j-j3,k ) + pz(i,j,k ) . + pz(i,j-j3,k+1) + pz(i,j,k+1) ) coef=0.25*pri*(c(i,j-j3,k)+c(i,j,k))* 1 (rho(i,j-j3,k)+rho(i,j,k)) pya=dyi*(p(i,j,k)-p(i,j-j3,k)) hy(i,j,k)=( G22a*pya + g23*pza )*coef end do end do end do #if (POLES == 0) create boundary conditions at j=1 if(ibcy.eq.1) call updatebt(hy,np,mp,l,np,mp,1) if (botedge.eq.1) then do k=1,l do i=1,np hy(i,1,k)= (ibcy-1)*hy(i,2,k) + ibcy*hy(i,0,k) end do end do end if #endif endif compute z-flux at (i,j,k+-1/2) ! i) include the dh/dx and dh/dz terms call updatelr(hx,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do k=2,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g13=0.5*(gmul(k)+gmul(k-1))*s13(i,j)*G110 gii=gi(i,j) hxa=0.25*(hx(i,j,k-1)+hx(i+1,j,k-1)+hx(i,j,k)+hx(i+1,j,k)) coef=0.25*pri*(c(i,j,k)+c(i,j,k-1)) . *(rho(i,j,k)+rho(i,j,k-1)) hza=gii*pz(i,j,k)*coef*0.5*(Prinv(i,j,k)+Prinv(i,j,k-1)) hz(i,j,k)= gii*hza + g13*hxa end do end do end do #if (POLES == 0) if (rightedge.eq.1) then corporate b.c. for hx on i=n+1 do k=2,l do j=1,mp G110=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g13=0.5*(gmul(k)+gmul(k-1))*s13(np,j)*G110 gii=gi(np,j) hx1 = (ibcx-1)*hx(np,j,k-1) + ibcx*hx(np+2,j,k-1) hx2 = (ibcx-1)*hx(np,j,k) + ibcx*hx(np+2,j,k) hxa=0.25*(hx(np,j,k-1)+hx1+hx(np,j,k)+hx2) coef=0.25*pri*(c(np,j,k)+c(np,j,k-1)) . *(rho(np,j,k)+rho(np,j,k-1)) hza=gii*pz(np,j,k)*coef*0.5*(Prinv(np,j,k)+Prinv(np,j,k-1)) hz(np,j,k)= gii*hza + g13*hxa end do end do end if #endif ! ii) include the dh/dy term if 3D if(j3.eq.1) then call updatebt(hy,np,mp,l,np,mp,iupy) #if (POLES == 0) jllim = 1 julim = mp - 1*topedge #else jllim = 1 julim = mp #endif do k=2,l do j=jllim,julim do i=1,np G220=1./gmm(i,j,k) g23=0.5*(gmul(k)+gmul(k-1))*s23(i,j)*G220 hya=0.25*(hy(i,j,k-1)+hy(i,j+j3,k-1)+ 1 hy(i,j,k)+hy(i,j+j3,k)) hz(i,j,k)=hz(i,j,k) + g23*hya end do end do end do #if (POLES == 0) if (topedge.eq.1) then do k=2,l do i=1,np corporate b.c. for hy on j=m+1 G220=1./gmm(i,mp,k) g23=0.5*(gmul(k)+gmul(k-1))*s23(i,mp)*G220 hy1= (ibcy-1)*hy(i,mp,k-1) + ibcy*hy(i,mp+2,k-1) hy2= (ibcy-1)*hy(i,mp,k) + ibcy*hy(i,mp+2,k) hya=0.25*(hy(i,mp,k-1)+hy1+hy(i,mp,k)+hy2) hz(i,mp,k)=hz(i,mp,k) + g23*hya end do end do endif #endif endif create boundary conditions at k=1; for k=L see divergence below IF(IBCZ.EQ.0) THEN c surface fluxes: if (itf.eq.1) then ! temperature, do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 hz(i,j,1)=-2.*sqrt(g33)*rho(i,j,1)*hfx(i,j)-hz(i,j,2) enddo enddo else if (itf.eq.-1) then ! moisture, do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 hz(i,j,1)=-2.*sqrt(g33)*rho(i,j,1)*qfx(i,j)-hz(i,j,2) enddo enddo else do j=1,mp do i=1,np c hz(i,j,1)=-hz(i,j,2) hz(i,j,1)= hz(i,j,2) end do end do end if ELSE do j=1,mp do i=1,np hz(i,j,1)= hz(i,j,L) end do end do ENDIF compute Laplacian term by term do k=1,l do j=1,mp do i=1,np r(i,j,k)=0. end do end do end do compute d/dx(dh/dx) #if (POLES == 0) illim = 1 iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G11p=1./((1-icylind)*gmm(i+1,j,k)*cosa(i+1,j)+icylind*1.) r(i,j,k) = dxi*(hx(i+1,j,k)*G11p-hx(i,j,k)*G110) end do end do end do #if (POLES == 0) create boundary conditions on hx at i=n+1 if (rightedge.eq.1) then do j=1,mp do k=1,l hxn=hx(np,j,k) hxnp1 = (ibcx-1)*hxn + ibcx*hx(np+2,j,k) r(np,j,k) = dxi*(hxnp1-hxn) end do end do end if #endif c for 3D problem compute d/dy(dh/dy) and add to r if(j3.eq.1) then #if (POLES == 0) jllim = 1 julim = mp - 1*topedge #else jllim = 1 julim = mp #endif do k=1,l do j=jllim,julim do i=1,np G220=1./gmm(i, j ,k) G22p=1./gmm(i,j+1,k) r(i,j,k) = r(i,j,k) + dyi*(hy(i,j+1,k)*G22p-hy(i,j,k)*G220) end do end do end do #if (POLES == 0) create boundary conditions at j=m+1 if (topedge.eq.1) then do k=1,l do i=1,np hymp1= (ibcy-1)*hy(i,mp,k) + ibcy*hy(i,mp+2,k) r(i,mp,k) = r(i,mp,k) + dyi*(hymp1-hy(i,mp,k)) end do end do end if #endif endif compute d/dz(dh/dz) and add to r IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np do k=1,l-1 r(i,j,k) = r(i,j,k) + dzi*(hz(i,j,k+1)-hz(i,j,k)) end do corporate b.c. hz(i,j,L+1)=-hz(i,j,L) at k=L c hzLp1 =-hz(i,j,l) hzLp1 = hz(i,j,l) r(i,j,l) = r(i,j,l) + dzi*(hzLp1-hz(i,j,l)) end do end do ELSE do j=1,mp do i=1,np do k=1,l-1 r(i,j,k) = r(i,j,k) + dzi*(hz(i,j,k+1)-hz(i,j,k)) end do corporate b.c. hz(i,j,L+1)=-hz(i,j,L) at k=L r(i,j,l) = r(i,j,1) end do end do ENDIF do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)/rho(i,j,k) end do end do end do call update(r,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(48) #endif return end subroutine pertth(th,ishft) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) #if (TIMEPLT == 1) call ttbeg(50) #endif do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 th(i,j,k)=th(i,j,k)+ishft*the(i,j,k) #if (TIMEPLT == 1) call ttend(50) #endif return end subroutine tinit(z,x,y,tau,lipps,initi) include 'param.nml' include 'msg.inc' dimension z(l),x(n),y(m) dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) #if (TIMEPLT == 1) call ttbeg(9) #endif c if(initi.eq.1) call tinit_i(z,x,y,tau,lipps) if(initi.eq.0) call tinit_r(z,tau,lipps) c #if (TIMEPLT == 1) call ttend(9) #endif return end subroutine tinit_r(z,tau,lipps) calculate initial profiles when starting from real sounding include 'param.nml' include 'msg.inc' dimension z(l) dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw c original davies coefficients for nr(x or y)=6 c data relb/1.,0.98,0.9,0.5,0.1,0.02/ common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs dimension tme1(l),the1(l),qve1(l),ue1(l),ve1(l) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccc environmental sounding: ccc you may enter either pressure or height for a given level ccc (the other one should be set to zero and this subroutine ccc will automatically calculate it); if you do not use potential ccc temperature on input, activate the appropriate code below. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(npin=31) dimension press(npin),temp(npin),zin(npin), 1 vap(npin),uu(npin),vv(npin) cc pressure in hPa: DATA PRESS/1017.,1000.,980.,960.,950.,930.,910.,900.,875., . 850.,840.,830.,820.,810.,800.,775.,750.,700.,650.,600.,550., . 500.,450.,400.,350.,300.,250.,200.,150.,100.,50./ cc height in m: DATA ZIN /NPIN*0./ cc potential temperature in K: DATA TEMP/25.0,23.5,21.8,20.2,19.7,18.8,18.0,17.7,16.5,15.4, . 15.0,15.5,15.8,15.6,15.2,14.3,13.0,10.0, 6.7, 3.0,-1.3,-6.0, . -11.2,-17.0,-24.0,-32.9,-43.5,-55.0,-67.0,-77.0,-77.0/ ccwater vapor mixing ratio in g/kg: DATA VAP/15.6,14.7,13.7,12.7,12.0,11.0,10.0,9.6,8.6,7.6,7.2, . 6.9,6.5,6.2,5.9,5.3,4.6,3.5,1.9,0.9,0.5,0.46,0.31,0.20,0.11, . 0.05,0.015,0.004,0.0009,0.0002,0.0001/ cc x and y velocity components in m/s: DATA UU/19*-10.3,-8.5,-6.0,-3.5,-1.25,0.5,2.25,3.6,4.25, . 3.75,1.0,-9.8,-17.3/ DATA VV/22*0.,7.8,7.8,7.6,6.9,4.0,1.0,0.3,0.1,0./ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt convert from temperature (deg C or K) into potential temperature do k=1,npin c temp(k)=temp(k)*(1.e3/press(k))**(rg/cp) temp(k)=(temp(k)+273.16)*(1.e3/press(k))**(rg/cp) enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc utr=0. do ip=1,npin uu(ip)=uu(ip)-utr enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute approximated height of pressure levels: if (zin(2).lt.1.e-4) then zin(1)=0. do k=2,npin km=k-1 tempk =temp(k )*(1.e3/press(k ))**(-rg/cp) . * (1.+.6e-3*vap(k )) tempkm=temp(km)*(1.e3/press(km))**(-rg/cp) . * (1.+.6e-3*vap(km)) delt=tempk-tempkm if (delt.gt.1.e-4) then tavi=alog(tempk/tempkm)/delt else tavi=1./tempk endif deltz=-rg/(tavi*g) * alog(press(k)/press(km)) zin(k)=zin(km)+deltz end do end if compute approximate pressure of height levels: if (press(1).lt.1.e-4) then press(1)=pr00/100. do k=2,npin km=k-1 tempk =temp(k ) tempkm=temp(km) delt=tempk-tempkm if (delt.gt.1.e-4) then tavi=alog(tempk/tempkm)/delt else tavi=1./tempk endif rc=rg/cp rci=1./rc press(k)=( press(km)**rc - . g*(1.e3)**rc*tavi*(zin(k)-zin(km))/cp )**rci enddo endif c print*,'INPUT SOUNDING' c do k=1,npin c print 921,k,zin(k),press(k),temp(k),vap(k) c921 format(1x,'k,z,p,theta,qv: ',i4,4e17.5) c enddo compute environmental profiles from sounding assuming no topography: cc surface data: iisn=1 the1(1)=temp(iisn) tme1(1)=the1(1) * (1000./press(iisn))**(-rg/cp) qve1(1)=vap(iisn)*1.e-3 ue1(1)=uu(1) ve1(1)=vv(1) c print*,'DETERMINED SURFACE DATA' cc higher levels - interpolate: c print*,'INTERPOLATION TO HIGHER LEVELS' do k=2,l c print*,'k=',k do kk=2,npin iisn=kk-1 if(zin(kk).ge.z(k)) go to 665 enddo c print*,'INPUT SOUNDING DOES NOT GO HIGH ENOUGH. STOP.' stop 'SOUNDING' 665 continue c print*,'iisn=',iisn coe2=(z(k)-zin(iisn))/(zin(iisn+1)-zin(iisn)) the1(k)=coe2*temp(iisn+1) + (1.-coe2)*temp(iisn) qve1(k)=(coe2*vap(iisn+1) + (1.-coe2)*vap(iisn))*1.e-3 presnl=coe2*press(iisn+1) + (1.-coe2)*press(iisn) tme1(k)=the1(k) * (1000./presnl)**(-rg/cp) ue1(k)=coe2*uu(iisn+1) + (1.-coe2)*uu(iisn) ve1(k)=coe2*vv(iisn+1) + (1.-coe2)*vv(iisn) end do c print*,'ENVIRONMENTAL PROFILES' do k=1,l c print 200,z(k)/1.e3,the1(k),tme1(k),qve1(k)*1.e3,ue1(k),ve1(k) 200 format(1x,'z,the,tme,qve,ue,ve:',3f10.3,e12.3,2f10.3) enddo compute th00,tt00,pr00,rh00 and average stability for base state profiles th00=the1(1) tt00=tme1(1) tvirt=tme1(1)*(1.+.6*qve1(1)) rh00=press(1)*100./(rg*tvirt) pr00=press(1)*100. sum=0. do k=2,l-1 sum = sum + (the1(k+1)-the1(k-1))/the1(k) enddo st=sum/(float(l-2)*2.*dz) c print*,'th00,tt00,pr00,rh00,st: ',th00,tt00,pr00,rh00,st c smooth environmental profiles c filter 2 and 4 dz waves call filtprf(the1,l,1,1) call filtprf(ue1 ,l,1,1) call filtprf(ve1 ,l,1,1) call filtprf(tme1,l,1,1) call filtprf(qve1,l,1,1) create environmental profiles; topography is now considered: do i=1,np do j=1,mp do k=1,l zstr=fsi(z(k)) zcr(k)=zstr/gi(i,j)+zs(i,j) end do if (moist.eq.1) then do k=1,l kk=zcr(k)/dz+1 kk=min(l,max(1,kk)) kkp=min(l,kk+1) coe=(zcr(k)-z(kk))/dz tme(i,j,k)=coe*tme1(kkp)+(1.-coe)*tme1(kk) qve(i,j,k)=coe*qve1(kkp)+(1.-coe)*qve1(kk) the(i,j,k)=coe*the1(kkp)+(1.-coe)*the1(kk) ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) end do else do k=1,l kk=zcr(k)/dz+1 kk=min(l,max(1,kk)) kkp=min(l,kk+1) coe=(zcr(k)-z(kk))/dz the(i,j,k)=coe*the1(kkp)+(1.-coe)*the1(kk) ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) end do endif compute reference state vertical profiles for every x,y point call thprof(tau(1,i,j,1),zcr,l,lipps) do k=1,l th0(i,j,k)=tau(k,i,j,1) end do call rhprof(tau(1,i,j,1),zcr,l,lipps) do k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rho(i,j,k)=tau(k,i,j,1)/(gi(i,j)*gmus(k)) + *((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnmi rhoi(i,j,k)=1./rho(i,j,k) end do end do end do call update(th0,np,mp,l,np,mp,1) call update(rho,np,mp,l,np,mp,iup) call update(the,np,mp,l,np,mp,iup) call update(ve, np,mp,l,np,mp,1) call update(ue, np,mp,l,np,mp,1) if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp,1) call update(tme,np,mp,l,np,mp,1) end if call absorber(z,x,y,tau) call theimpl(tau) ! theta_e derivatives for implict model return end subroutine tinit_i(z,x,y,tau,lipps) c --- z,x,y are computational (transformed) coordinate arrays c --- tau is Rayleigh sponge damping field c --- lipps is flag for type of basic state (see below) calculate initial profiles when starting from idealized sounding include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension x(n),y(m),z(l),aa(l),bb(l),ue0(l),ve0(l), 1 the0(l),te0(l),pe0(l),pe(l) c mihai mods for politropic model and/or stable layer dimension theq0(l) dimension tkapp(l) real n1,n2,n2e,n10,nad !polytropic indices for the ambient theta real k0, k0i, k0e, gte(l+1), gth(l+1) parameter (gkst=530.,th0kst=2.13e6,tt0kst=2.13e6,rh0kst=176.) common/diffus/ sk(l),skr(l),sls c --------------------- end of mihai mods common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/htflx/ hflx(l+1) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profrhoi/rhoi(np,mp,l) common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/enstprof/ tes(l),thes(l),rhoes(l) common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/temp_p/ tup,tdn common/latent/ hlatv,hlats common /hstst/ theq(1-ih:np+ih,1-ih:mp+ih,l), . dfhs(1-ih:np+ih,1-ih:mp+ih,l), . hskf,hska,hsks, . qveq(1-ih:nmsp+ih,1-ih:mmsp+ih,lms) c --- th0,rho are basic state potential temperature and density fields c --- the,ue,ve are environmental theta, zonal, and meridional wind c --- wind fields c --- zcr is physical vertical coordinate (i.e., in reference system) c --- theq,tme,qve are moist theta, temperature, and water vapor c --- mixing ratio fields common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/mihaistr/ acns,beta,dzb,hpsl,kst c alim01(fi)=amax1(0.,amin1(1.,fi)) c comb(tm,td,tu,ad,au)= c 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad c --- vertical stretching c ! GGstr: stretiching Chan&Sofia c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt !GGstr: stretiching Chan&Sofia ! H in the notes is zb ! R in the notes is rds ! I'm going to use SD as our coefficient Zg ! and will use fs as our function f ! parameter(SD = 10.) ! fs(zt) = (exp((zb - zt)*log(1. + SD)/zb) - 1.)/SD pi=acos(-1.) capi=1./cap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute basic and environmental state profiles for every x,y point c --- CAUTION: in general these will be time variable! c --- physical altitude do j=1,mp do i=1,np do k=1,l zstr=fsi(z(k)) zcr(k)=zstr/gi(i,j)+zs(i,j) !GGstr: the variable zcr is z in the notes ! zcr(k) = zb*(1.-fs(z(k)))/(1.+ zb*fs(z(k))/rds) enddo enddo enddo npoly=1 if (npoly.eq.1) then c build ambient theta profile (from temperature and density) assuming c polytropic stratification n1=3.0 !polytropic index at the base of the SL below SCZ c n2=1.49999 !polytropic index for the SCZ n2=1.4999945 !polytropic index for the SCZ c n2=1.499996 !polytropic index for the SCZ c n2=1.499992 !polytropic index for the SCZ nad=1.5 dn120=n1-nad dn220=nad-n2 c intrfc=1 intrfc=0 itanh=1 if(intrfc.eq.1) then kst = 1 + hpsl/dz tes(kst) = tt0kst rhoes(kst) = rh0kst trs(kst) = tt0kst rhors(kst) = rh0kst thes(kst) = tt0kst gup = gkst do k=kst-1,1,-1 c n10 = n1 n10 = n1 - dn120*zcr(k)/hpsl rul = (rds+zcr(k+1))/(rds+zcr(k)) dtemp = gup*dz*rul/(rg*(n10+1)) dtempa = gup*dz*rul/(rg*(nad+1)) tes(k) = tes(k+1) + dtemp trs(k) = trs(k+1) + dtempa rhoes(k) = rhoes(k+1)/(1.-dtemp/tes(k))**n10 rhors(k) = rhors(k+1)/(1.-dtempa/trs(k))**nad thes(k) = tes(k)*(rh0kst*tt0kst/(rhoes(k)*tes(k)))**cap gup = gkst*((rds+zcr(kst))/(rds+zcr(k)))**2 enddo gb = gkst do k=kst+1,l if (itanh.eq.1) then select case(l) !modif for different l case(24) n10 = nad + dn220*0.5*(tanh(1.4*(kst+2.5-k))+ & tanh(1.4*(k-l+2.5))) case(47) n10 = nad + dn220*0.5*(tanh(0.6*(kst+6-k))+ & tanh(0.6*(k-l+6))) case(93) n10 = nad + dn220*0.5*(tanh(0.3*(kst+12-k))+ & tanh(0.3*(k-l+12))) case(185) n10 = nad + dn220*0.5*(tanh(0.15*(kst+24-k))+ & tanh(0.15*(k-l+24))) end select else n10 = n2 endif rlu = (rds+zcr(k-1))/(rds+zcr(k)) dtemp = gb*dz*rlu/(rg*(n10+1)) dtempa = gb*dz*rlu/(rg*(nad+1)) tes(k) = tes(k-1) - dtemp trs(k) = trs(k-1) - dtempa rhoes(k) = rhoes(k-1)*(1.-dtemp/tes(k-1))**n10 rhors(k) = rhors(k-1)*(1.-dtempa/trs(k-1))**nad thes(k) = tes(k)*(rh0kst*tt0kst/(rhoes(k)*tes(k)))**cap gb = gkst*((rds+zcr(kst))/(rds+zcr(k)))**2 enddo tt00 = trs(1) th00 = thes(kst) rh00 = rhors(1) pr00=rg*rh00*tt00 else !intrfc=0 tes(1)=tt00 thes(1)=tt00 rhoes(1)=rh00 do k=2,l if (zcr(k).le.hpsl) then c n10 = n1 n10 = n1 - dn120*zcr(k)/hpsl else if (itanh.eq.1) then select case(l) !modif for different l case(24) n10 = nad + dn220*0.5*(tanh(1.4*(kst+2.5-k))+ & tanh(1.4*(k-l+2.5))) case(47) n10 = nad + dn220*0.5*(tanh(0.6*(kst+6-k))+ & tanh(0.6*(k-l+6))) case(93) n10 = nad + dn220*0.5*(tanh(0.3*(kst+12-k))+ & tanh(0.3*(k-l+12))) case(185) n10 = nad + dn220*0.5*(tanh(0.15*(kst+24-k))+ & tanh(0.15*(k-l+24))) end select else n10 = n2 endif endif hb=rg*tes(k-1)*((rds+zcr(k-1))/rds)**2/g tes(k)=tes(k-1)*(1.-(rds+zcr(k-1))*(zcr(k)-zcr(k-1))/ & ((n10+1.)*hb*(rds+zcr(k)))) rhoes(k)=rhoes(k-1)*(1.-(rds+zcr(k-1))*(zcr(k)-zcr(k-1))/ & ((n10+1.)*hb*(rds+zcr(k))))**(n10) thes(k)=tes(k)*(rh00*tt00/(rhoes(k)*tes(k)))**cap enddo c --- basic state temperature call tprof(trs,zcr,l,lipps) c --- basic state density call rhprof(rhors,zcr,l,lipps) c --- basic state pressure c call pprof(prs,zcr,l,lipps) endif !intrfc=1 endif !npoly=1 ! iudm=0 if (iudm.eq.1) then open (unit=2,file='/RQexec/ghizarum/krt_udm_sl47.txt', & status='old') c read (2,100) (skr(k), k=1,l) close(unit=2) 100 format (6e15.6) endif c --- basic state potential temperature call thprof(thrs,zcr,l,lipps) if(mype.eq.0) then do k=1,l write(17,906) trs(k),thrs(k),tes(k),thes(k),rhors(k) enddo endif 906 format(5x,6f15.6) c 906 format(4x,6e15.6) call ambient(thes,tkapp) do 12 k=1,l do 12 j=1,mp do 12 i=1,np th0(i,j,k)=thrs(k) if (npoly.eq.1) then the(i,j,k)=thes(k) else the(i,j,k)=thrs(k) endif 12 continue c------------------------------------------------------------------c C IDEALIZED BASIC STATE PROFILES c c c c NOTE: pressure and temperature profiles c c are NOT computed unless MOISTMOD > 0 c c c c lipps = 0: This is classical BOUSSINESQ approximation. c c Constant density, linearly decreasing c c (p,T) -> there exists max. altitude c c beyond which profiles are nonphysical c c Th = T. c c c c lipps = 1: Ogura and Phillips ANELASTIC: see JAS V. c c 19, pp. 173-179, 1962. Characterized c c by single scale height - hr. c c Th = constant (isentropic atm.) c c T = linearly decreasing profile. c c -> there exists a height restriction c c beyond which profiles are nonphysical c c c c lipps = 2: Clark and Farley ANELASTIC: see JAS V.41, c c pp. 329-350, 1984. Assumes exp. profile c c for th with scale height - ht. Value of c c cp (or equivalently, cap) is chosen c c as second indepenent parameter. c c (rho,p,T) are all nonlinearly decreasing c c and go to zero value at finite altitude c c -> there exists a height restriction c c beyond which profiles are nonphysical c c c c lipps = 3: Bacmeister and Schoeberl ANELASTIC: see c c JAS V. 46, pp. 2109-2134, 1989. Assumes c c exp. profiles for rho and th with scale c c heights hr and ht, respectively. c c -> T = constant (isothermal atm.) c c No height restriction. c c c c------------------------------------------------------------------c do 10 j=1,mp do 10 i=1,np if(mhd.eq.0) then do 13 k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rho(i,j,k)=rhors(k)/(gi(i,j)*gmus(k)) + *((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnmi if(dnmi.lt.0.and.k.eq.1) print*,'DNMI:',i,j,k, . rho(i,j,k),dnmi,stryy(i,j),strxx(i,j),stryx(i,j),strxy(i,j) rhoi(i,j,k)=1./rho(i,j,k) 13 continue else do k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rh0(i,j,k)=1./(gi(i,j)*gmus(k))* + ((1-icylind)*gmm(i,j,k)**2*cosa(i,j)+icylind*gmm(i,j,k))*dnmi rho(i,j,k)=rhors(k)*rh0(i,j,k) rhoi(i,j,k)=1./rho(i,j,k) enddo endif c------- construct environmental wind if(u0z.ge.1.e-15) then do k=1,l ue0(k)=u00+u0z*zcr(k) ! specified shear enddo else do k=1,l ue0(k)=u00*gmm(i,j,k) ! ~constant in altitude enddo u0s=u00*rdsi endif c------- construct geostrophic environmental state do 14 k=1,l ue(i,j,k)=ue0(k)*cosa(i,j) ve(i,j,k)=v00 14 continue if(mhd.eq.1) then imhd = 0 !mod init Bxe if(imhd.eq.1) then ampB=0.0001 hwln=y(m)-y(1) y0c=(y(m)+y(1))*.5 ja=(mpos-1)*mp + j argm=pi*(y(ja)-y0c)/hwln cosbt=cos(argm) endif do k=1,l C coslc=isphere*cosa(i,j)+(1-isphere)*cosbt c coslc=1 C bxe(i,j,k)=ampB*(coslc**2) C . *sin( pi*(zcr(k)/(zh(i,j)-zs(i,j))) ) bxe(i,j,k)=0. bye(i,j,k)=0. bze(i,j,k)=0. enddo endif if( icylind.eq.1) then do k=1,l ve(i,j,k)=ve0(k) ue(i,j,k)=ue0(k) the0(k)=th0(i,j,k) if(lipps.eq.0) the0(k)=th00*(1.- st*zcr(k)) the(i,j,k)=the0(k) enddo endif ihs=0 ! Held-Suarez flow if(ihs.eq.1) then c------------------------------------------------------------------c c c c See Held and Suarez, Bulletin of the AMS, V. 75, c c pp. 1825-1830, 1994 c c c c NOTE: th00 = 315K for HS paper c c c c------------------------------------------------------------------c c c --- construct dry part held-suarez environmental state hskf=1./( 24.*3600.) hska=1./(40.*24.*3600.) hsks=1./(4. *24.*3600.) sigb=0.7 sigi=1./(1.-sigb) dthy=60. dthz=10. hd=7000. ! density scale height xs=th00-dthy*sina(i,j)**2 xc=dthz*cosa(i,j)**2 do 5 k=1,l sgm=exp(-zcr(k)/hd) ! Basic state (p/p_ref) approx. sg0=sgm**cap ! conversion factor for temp->theta thstr=200./sg0 dfhs(i,j,k)=amax1(0., sigi*(sgm-sigb) ) theq(i,j,k)=amax1(thstr,xs-xc*alog(sgm)) ! full HS profile theqtmp = theq(i,1,k) ! sub HS profile #if (PARALLEL == 2) if(mpos.eq.1) then do idest=npos+nprocx-1,mysize-1,nprocx call MPI_Send(theqtmp,1,DC_TYPE, . idest,21,MPI_COMM_EULAG,ierr) enddo else isource=npos-1 call MPI_RECV(theqtmp,1,DC_TYPE, . isource,21,MPI_COMM_EULAG,status,ierr) endif call mybarrier() #endif the(i,j,k)=theqtmp 5 continue endif ! set HD environment = basic state cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (MOISTMOD > 0) #if (MOISTMOD == 1) c------- profiles for pressure, temperature, and relative humidity if(ihs.eq.1) then pr00=g*hd*rh00 do k=1,l pe(k)=pr00*exp(-zcr(k)/hd) tme(i,j,k)=the(i,j,k)*(pe(k)/pr00)**cap qve(i,j,k)=.92 ! set relative humidity end do else call teprof(pe0,te0,zcr,l,lipps) do k=1,l pe(k)=pe0(k) tme(i,j,k)=te0(k) qve(i,j,k)=.92 ! set relative humidity end do end if c -------------------------------------------------------------- c --- initialize env. moisture fields using Grawboski thermodynamics if(ice.eq.1) then ! COLD RAIN a=rg/rv b=hlats/rv d=hlatv/rv e=-cp/rg do k=1,l coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e ! modify? tti=tme(i,j,k) delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) ! modify? qvsi=a * esi /(pre-esi) ! modify? qvs=coe_l*qvsw + (1.-coe_l)*qvsi qve(i,j,k)=qve(i,j,k)*qvs c --- held-suarez test if(ihs.eq.1) then tti=theq(i,j,k)/thetme coe_l=comb(tti,tdn,tup,0.,1.) ! liquid contribution delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) ! modify? qvsi=a * esi /(pre-esi) ! modify? qvs=coe_l*qvsw + (1.-coe_l)*qvsi qveq(i,j,k)=0.9*qvs ! set relative humidity end if c --- end HS test end do else ! WARM RAIN a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do k=1,l thetme=the(i,j,k)/tme(i,j,k) thi=1./the(i,j,k) c thetme=the0(k)/te0(k) !uniform qv on the planet c thi=1./the0(k) !uniform qv on the planet pre=1.e5*thetme**e ! modify? ylc=b*thetme*t00*thi ees=ee0*exp(b-ylc) qvs=a*ees/(pre-ees) ! modify? qve(i,j,k)=qve(i,j,k)*qvs c --- held-suarez test if(ihs.eq.1) then thi=1./theq(i,j,k) ylc=b*thetme*t00*thi ees=ee0*exp(b-ylc) qvs=a*ees/(pre-ees) ! modify? qveq(i,j,k)=0.9*qvs ! set relative humidity end if c --- end HS test end do endif #endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 10 continue c compute thermal and radiative diffusivities for SUN iskrsm = 0 ! 1 for computing like in GONG report 14 sig=5.67e-8 ! W/(m^2*K^4) Stefan-Boltzmann if (iskrsm.eq.1) then c00i = 7.1548412e12 !Christensen-Dalsgaard GONG report 14 betai = 1.97541 etai = 0.138316 c00e = 1.6236784e-34 !also in Espinosa, Rieutord 2007 betae = -9.28289 etae = 0.407895 do k=1,l k0i = c00i*tes(k)**(-betai)*rhoes(k)**etai k0e = c00e*tes(k)**(-betae)*rhoes(k)**etae k0 = 1./(1./k0i + 1./k0e) skr(k) = 16.*sig*tes(k)**3/(3.*cp*k0*rhoes(k)**2) if(mype.eq.0) print *,'skr,k:',skr(k),k enddo else !iudm=1 skr-from UDM model !c open (unit=2,file='/RQexec/ghizarum/cottos/mhd2/skr.txt', ! open (unit=2,file='skr.txt', ! & status='old') ! read (2,111) (skr(k), k=1,l) ! close(unit=2) !111 format (5e15.6) do k=1,l skr(k)=tkapp(k) !GG ! if(mype.eq.0) print*, skr(k) ! k0=0.034*(1.+6.*1.e21*rhoes(k)*tes(k)**(-3.5))!Kramers'(Ruediger) ! skr(k) = 16.*sig*tes(k)**3/(3.*cp*k0*rhoes(k)**2) enddo endif c compute radiative diffusivity based on solar luminosity c do k=1,l c skr(l)=sls/( -4.*pi*(rds+zcr(k))**2*rhors(k)*cp* c & 0.5*(gte(k)+gte(k+1)) ) c enddo sls=3.86e26 ! solar luminosity do k=1,l if (zcr(k).le.hpsl) then c sk(k) = 1.e-1 c sk(k) = 1.e7*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k))**2 c sk(k) = 1.e7*sqrt((rhobr(1)/rhobr(k))**3) c sk(k) = 1.e2 sk(k) = 1.e6 c sk(k) = 1.e7 c sk(k) = 1.e8 c sk(k) = 0. else c sk(k) = 1.e5*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k)) c sk(k) = 1.e4*(rhobr(1)/rhobr(k))**2 c sk(k) = 3.245e8 c sk(k) = 1.0e8 c sk(k) = sk(k)*1.e-1 c sk(k) = 1.e9 sk(k) = 1.e6 c sk(k) = 1.e7 c sk(k) = 1.e8 c sk(k) = 1.e2 c sk(k) = 0. endif enddo call update(th0,np,mp,l,np,mp,1) call update(rho,np,mp,l,np,mp,iup) call update(the,np,mp,l,np,mp,iup) call update(ve, np,mp,l,np,mp,1) call update(ue, np,mp,l,np,mp,1) if(mhd.eq.1) then call update(rh0,np,mp,l,np,mp,iup) call update(bxe,np,mp,l,np,mp,1) call update(bye,np,mp,l,np,mp,1) call update(bze,np,mp,l,np,mp,1) endif if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp,1) call update(tme,np,mp,l,np,mp,1) end if call absorber(z,x,y,tau) call theimpl(tau) ! theta_e derivatives for implict model create flux and roughness fields Z.S. do 30 j=1,mp do 30 i=1,np hfx(i,j)=hf00 ! heat flux in K*m/s 30 zo(i,j)=0.1 ! roughness parameter, m if (moist.eq.1) then do 31 j=1,mp do 31 i=1,np 31 qfx(i,j)=qf00 ! spec.hum.flux in kg/kg*m/s endif c special heat flux c zeta1=5. c zeta2=5. c do k=2,l c zcrn=(k*1.-1.5)/(l*1.-1.) c hflx(k)=((1.-exp(-zeta1-zeta2))/(zeta1*(1.-exp(-zeta2)))- c . exp(-zeta1*zcrn)/zeta1-(1.-exp(-zeta1))* c . exp(-zeta2*(1.-zcrn))/(zeta1*(1.-exp(-zeta2))))*(l*1.-1.) c hflx(k)=hflx(k)*(1.+((k-1.5)*dz)/rds)**2 c enddo c hflx(1)=-hflx(2) c hflx(l+1)=-hflx(l) c endof special return end ! subroutine ambient(th_amb,tkapp) ! include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp) common/polyindex/ m0,m1,m2,width_ic,z1,z2 . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) ! dimension pm0(l),tm0(l),z(l),rad(l),th_amb(l) dimension tkapp(l),rho_ad(l),t_ad(l),p_ad(l),th_ad(l) dimension rlnrhom(l),tempm(l),zz(l),dTdr(l),dTedr(l),rhom(l) dimension dlnTdr(l), dlnrdr(l),cs2(l),gravz(l) integer l1 real Gc, star_radii,temp0,rho0,dz,cap real u0(2),u1(2) external star_amb ! Gc=6.674e-11 rmin=rds star_radii = 6.9599e8 Rg=13732. cp=2.5*Rg temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 tempm(l1) = u0(1) rhom(l1) = u0(2) th_amb(l1)=tempm(l1)*(((temp0*rho0)/(tempm(l1)*rhom(l1)))**cap) DO k = 1,l rad(k) = rds + zcr(k) END DO DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_amb, u1) u0(1) = u1(1) u0(2) = u1(2) tempm(k) = u1(1) rhom(k) = u1(2) th_amb(k)=tempm(k)*(((temp0*rho0)/(tempm(k)*rhom(k)))**cap) r0 = r1 END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_amb, u1) u0(1) = u1(1) u0(2) = u1(2) tempm(k) = u1(1) rhom(k) = u1(2) th_amb(k)=tempm(k)*(((temp0*rho0)/(tempm(k)*rhom(k)))**cap) END DO ! ! --- isentropic state density call rhprof(rho_ad,zcr,l,1) call pprof(p_ad,zcr,l,1) call tprof(t_ad,zcr,l,1) if(mype.eq.0) then open(1,file="strat.dat") do k=1, l th_ad(k)=t_ad(k)*(((temp0*rho0)/(t_ad(k)*rho_ad(k)))**cap) write(1,'(F11.6,2x,F15.7,2x,F15.7,2x, & F15.7,2x,F15.7,2x,F15.7,2x,F15.7)') & rad(k)/star_radii, & tempm(k),rhom(k),th_amb(k),t_ad(k),rho_ad(k),th_ad(k) enddo close(1) endif return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! real function grav_rafa(x) real x real ag, bg, cg, dg ag = -7.67624479849e-24 bg = 1.65029739402e-14 cg = -1.26840190398e-05 dg = 3694.34945199 grav_rafa = ag*x**3 + bg*x**2 + cg*x + dg endfunction !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine star_isen (x,n,u,uprime) ! common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z integer n real x,mr, u(n),uprime(n) real g0, ag, bg, cg, dg g0 = grav_rafa(x) mr=1.5 uprime(1)=-g0/((mr+1.)*rg) uprime(2)=(u(2)/u(1))*(-g0/rg-uprime(1)) ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine star_amb (x,n,u,uprime) ! common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/sphere/ rds integer n real x,u(n),uprime(n),mr,m1,m0,m2,width,x1,x2 real g0,star_radius,xb real ag,bg,cg,dg ! g0 = g/(x/(rds))**2 ag = -7.67624479849e-24 bg = 1.65029739402e-14 cg = -1.26840190398e-05 dg = 3694.34945199 star_radius = 6.9599e8 x1 = 0.7*star_radius m0 = 2.5 m1 = 1.5001 width = 0.01*star_radius mr = m0 - (m0-m1)*0.5*(1. + erf((x-x1)/(width))) g0 = ag*x**3 + bg*x**2 + cg*x + dg uprime(1)=-g0/((mr+1.)*rg) uprime(2)=(u(2)/u(1))*(-g0/rg-uprime(1)) ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine rk4vec(t0,m,u0,dt,f,u) ! integer m, k external f real dt real f0(m),f1(m),f2(m),f3(m) real t0,t1,t2,t3 real u(m),u0(m),u1(m),u2(m),u3(m) ! call f(t0,m,u0,f0) ! t1=t0+dt/2.0D+00 do k=1,m u1(k)=u0(k)+dt*f0(k)/2.0D+00 enddo call f(t1,m,u1,f1) ! t2=t0+dt/2.0D+00 do k=1,m u2(k)=u0(k)+dt*f1(k)/2.0D+00 enddo call f(t2,m,u2,f2) ! t3=t0+dt do k=1,m u3(k)=u0(k)+dt*f2(k) enddo call f(t3,m,u3,f3) ! do k=1,m u(k)=u0(k)+dt*(f0(k)+2.0D+00*f1(k)+ & 2.0D+00*f2(k)+f3(k))/6.0D+00 enddo ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine rk5vec(x, m, f, dx, func, fnew) external func integer m real f(m), fnew(m), f1(m), f2(m), f3(m), f4(m), f5(m), f6(m) real k1(m), k2(m), k3(m), k4(m), k5(m), k6(m) real dx, x real x1, x2, x3, x4, x5, x6 f1(1:m) = f(1:m) x1 = x call func(x1, m, f1, k1) x2 = x + dx / 4. f2(1:m) = f(1:m) + (dx / 4.) * k1(1:m) call func(x2, m, f2, k2) x3 = x + dx / 4. f3(1:m) = f(1:m) + (dx / 8.) * (k1(1:m) + k2(1:m)) call func(x3, m, f3, k3) x4 = x + dx / 2. f4(1:m) = f(1:m) + (dx / 2.) * (2. * k3(1:m) - k2(1:m)) call func(x4, m, f4, k4) x5 = x + (3. * dx / 4.) f5(1:m) = f(1:m) + (dx / 16.) * (3. * k1(1:m) + 9. * k4(1:m)) call func(x5, m, f5, k5) x6 = x + dx f6(1:m) = f(1:m) + (dx / 7.) * (2. * k2(1:m) - 3. * k1(1:m) & + 12. * (k3(1:m) - k4(1:m)) + 8. * k5(1:m)) call func(x6, m, f6, k6) fnew(1:m) = f(1:m) + (dx / 90.) * (7. * k1(1:m) + 32. * k3(1:m) & + 12. * k4(1:m) + 32. * k5(1:m) + 7. * k6(1:m)) return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function deriv4(xi, yi, ni,l) integer ni, l real deriv4 real xi(ni), yi(ni) if(ni.eq.1) then deriv4=(-yi(ni+2)+4.*yi(ni+1)-3.*yi(ni))/(2.*(xi(ni+1)-xi(ni))) elseif(ni.eq.l) then deriv4=(3.*yi(l)-4.*yi(l-1)+yi(l-2))/(2.*(xi(ni)-xi(ni-1))) else deriv4=(yi(ni+1)-yi(ni-1))/(2.*(xi(ni)-xi(ni-1))) endif return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! subroutine bridge_init() include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" !HAD TO DEFINE THIS: character(LEN=5) :: frn_name real :: frn_dt, dummy(1) integer :: proc_eu, isize, irank real :: pi=3.1415926, dx, rcoors(l),gb_m,t_norm_frn logical :: lok integer, dimension(MPI_STATUS_SIZE) :: stat character(LEN=5) :: unit_system real :: unit_length, unit_time, unit_BB, unit_T integer :: MPI_COMM_XBEAM, ipx, ipy, ipz, ip, tag common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) !---------------------------------- if (tag_frn <= 0) return if (mype.eq.0) then !print *, 'Initializing Briging process - Eulag' ! ! Send length of name of foreign code. ! call MPI_SEND(5,1,MPI_INTEGER,0,tag_frn,MPI_COMM_WORLD,ierr) ! ! Send name of foreign code. ! call MPI_SEND('EULAG',5,MPI_CHARACTER,0,tag_frn,MPI_COMM_WORLD, +ierr) ! ! Send processor numbers of foreign code. ! call MPI_SEND((/1,nprocy,nprocx/),3,MPI_INTEGER,0,tag_frn, +MPI_COMM_WORLD, ierr) ! ! Send gridpoint numbers of foreign code. ! call MPI_SEND((/l,m,n/),3,MPI_INTEGER,0,tag_frn, +MPI_COMM_WORLD, ierr) ! ! Send unit system name and units. ! !HOW THIS CONVERTION HSOULD BE DONE? call MPI_SEND('SI ',5,MPI_CHARACTER,0,tag_frn, + MPI_COMM_WORLD,ierr) !SYSTEM OF UNITS call MPI_SEND(1. ,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! LENGTH call MPI_SEND(1.,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! TIME call MPI_SEND(1.,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! Magnetic Field call MPI_SEND(1. ,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! Temperature !print *, 'Sent Units - Eulag' ! ! Send domain extents of foreign code. j loops over r, theta, phi. ! call MPI_SEND((/rds,rds+dz*(l-1),0.,pi,0.,2*pi/),6,DC_TYPE,0, +tag_frn,MPI_COMM_WORLD,ierr) !call MPI_SEND((/0.7,1.,0.,pi,0.,2*pi/),6,MPI_DOUBLE,0,tag_frn,MPI_COMM_WORLD,ierr) ! ! Send output timestep of foreign code (code units) ! call MPI_SEND(dt00*nbridge,1,DC_TYPE,0,tag_frn, +MPI_COMM_WORLD,ierr) ! ! Receive confirmation flag that setup is acceptable. ! call MPI_RECV(lok,1,MPI_LOGICAL,0,tag_frn, + MPI_COMM_WORLD,stat,ierr) if (.not.lok) then print*, 'not ok - EULAG' endif ! print *, 'EULAG - LOK' ! ! Send vector of global r-grid points. ! gb_m=0. do i=0,l-1 rcoors(i+1)=rds+i*dz gb_m=gb_m+grav_rafa(rcoors(i+1)) enddo gb_m = gb_m/l !print*, 'Eulag xcoords', dz call MPI_SEND(rcoors,l,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! ! Send normalized time for PENCIL, using average of Rafa's gravity ! t_norm_frn = sqrt(rds/gb_m) print*, 'EULAG - tnorm',dz,gb_m, t_norm_frn, l call MPI_SEND(t_norm_frn,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! ! Receive number of x-procs from Pencil. ! call MPI_RECV(nprocx_frn,1,MPI_INTEGER,0, +tag_frn,MPI_COMM_WORLD,stat,mpierr) call MPI_RECV(nprocy_frn,1,MPI_INTEGER,0, +tag_frn,MPI_COMM_WORLD,stat,mpierr) ! print *, 'EULAG - nproc_frn' ! ! Receive index range of buddy processors. ! do ip=0,nprocx_frn-1 tag=tag_frn+ip ! print *, 'EULAG - ip, tag : ', ip, tag call MPI_RECV(xind_rng(ip,:),2,MPI_INTEGER,ip,mype, + MPI_COMM_WORLD,stat,ierr) enddo !print *, 'EULAG - rank, xind', xind_rng(0:nprocx_frn-1,:) #endif endif c GM: Next block is to learn the position differences in terms of ranks from EULAG code and frn code call MPI_BCAST(nprocx_frn,1,MPI_INTEGER,0, +MPI_COMM_EULAG,ierr) call MPI_BCAST(nprocy_frn,1,MPI_INTEGER,0, +MPI_COMM_EULAG,ierr) call MPI_BCAST(xind_rng(0:nprocx_frn-1,:),2*nprocx_frn, + MPI_INTEGER,0, + MPI_COMM_EULAG,ierr) ! print *, 'EULAG - xind_rng', mype, xind_rng(0,1),xind_rng(0,2), ! . xind_rng(1,1),xind_rng(1,2) call find_proc_coord(mype, ipx, ipy) !peer_frn = mype * nprocx_frn peer_frn = ipx*nprocx_frn*nprocy_frn+ipy*nprocx_frn !print *, 'EULAG mype peer_frn', mype, peer_frn return end function u0_char(i,j,k) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/corio/ fcr0 ! Guilherme's function for differential rotation profile ! Although the function and variables are named _char, they are Andrés. real omega_c, omega_E, omega_char, omega_p real u0_char real a, pi, pi2 real r_tcl, w_tcl real rsun !if(mype.eq.0) print*, "fcr0 = ", fcr0 fcr0 = 6.060171e-6 * icorio !Constants based on Andrés paper pol_rate = 0.764 ! This rates comes from the first setup eq_rate = 1.092 !we did. omega_c = fcr0/2. ! Omega Core - Given by half the fcr0 variable omega_E = omega_c*eq_rate ! Omega Equator omega_p = omega_c*pol_rate ! Omega Poles a = 2.0*0.483 ! Strength of the "cos" terms in omega_s !!!!!!!!!!!!!!!!!!!!! pi=acos(-1.) pi2=2.*pi rsun = 6.96e8 r_tcl = 0.7*rsun w_tcl = 0.02*rsun omega_s = a*(sina(i,j))**2. + (1- a)*(sina(i,j))**4. rad = (rds+zcr(k)) fe = 0.5*(1+erf((rad-r_tcl)/w_tcl)) !I took out the Omega_c front term. No need for 2pi, it is already incerted into omegas omega_char=(fe*(omega_e-omega_c+(omega_p-omega_e)*omega_s)) u0_char = rad*cosa(i,j)*omega_char return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine theimpl(tau) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) if(implgw.eq.1) then dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do k=1,l do j=1,mp do i=illim,iulim dthe(i,j,k,1)=dxil*(the(i+1,j,k)-the(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dthe(1 ,j,k,1)=(1-ibcx)*dxi*(the(2,j,k)-the( 1,j,k)) . +ibcx*dxil*(the(2,j,k)-the(-1,j,k)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp dthe(np,j,k,1)=(1-ibcx)*dxi*(the(np,j,k)-the(np-1,j,k)) . +ibcx*dxil*(the(np,j,k)-the(np+2,j,k)) enddo enddo endif #endif do k=1,l do i=1,np do j=jllim,julim dthe(i,j,k,2)=dyil*(the(i,j+j3,k)-the(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dthe(i,1,k,2)=(1-ibcy)*dyi*(the(i,1+j3,k)-the(i, 1,k)) . +ibcy*dyil*(the(i,1+j3,k)-the(i,1-2*j3,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dthe(i,mp,k,2)=(1-ibcy)*dyi*(the(i,mp,k)-the(i,mp- j3,k)) . +ibcy*dyil*(the(i,mp,k)-the(i,mp+2*j3,k)) enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np dthe(i,j,k,3)=dzil*(the(i,j,k+1)-the(i,j,k-1)) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np dthe(i,j,1,3)= dzi*(the(i,j,2)-the(i,j,1)) dthe(i,j,l,3)= dzi*(the(i,j,l)-the(i,j,l-1)) enddo enddo else do j=1,mp do i=1,np dthe(i,j,1,3)= dzil*(the(i,j,2)-the(i,j,l-1)) dthe(i,j,l,3)= dzil*(the(i,j,2)-the(i,j,l-1)) enddo enddo endif dth=0.5*dt do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) dthx=dth*(g11*dthe(i,j,k,1) + g12*dthe(i,j,k,2) + + g13*dthe(i,j,k,3)) dthy=dth*(g21*dthe(i,j,k,1) + g22*dthe(i,j,k,2) + + g23*dthe(i,j,k,3)) dthz=dth* g33*dthe(i,j,k,3) c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astri=1./(1.+astr) dthe(i,j,k,1)=dthx*astri dthe(i,j,k,2)=dthy*astri dthe(i,j,k,3)=dthz*astri enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then call updatelr(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call updatelr(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call updatelr(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,l do j=1,mp dthe(np,j,k,1)=dthe(np+1,j,k,1) dthe(np,j,k,2)=dthe(np+1,j,k,2) dthe(np,j,k,3)=dthe(np+1,j,k,3) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call updatebt(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call updatebt(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np dthe(i,mp,k,1)=dthe(i,mp+j3,k,1) dthe(i,mp,k,2)=dthe(i,mp+j3,k,2) dthe(i,mp,k,3)=dthe(i,mp+j3,k,3) enddo enddo endif endif #else call update2(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update2(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call update2(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) #endif if(ibcz.eq.1) then do j=1,mp do i=1,np dthe(i,j,l,1)=dthe(i,j,1,1) dthe(i,j,l,2)=dthe(i,j,1,2) dthe(i,j,l,3)=dthe(i,j,1,3) enddo enddo endif else do k=1,l do j=1,mp do i=1,np dthe(i,j,k,1)=0. dthe(i,j,k,2)=0. dthe(i,j,k,3)=0. enddo enddo enddo endif return end subroutine absorber(z,x,y,tau) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension x(n),y(m),z(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . src(1-ih:np+ih, 1-ih:mp+ih, l-1), . tmp(1-ih:np+ih, 1-ih:mp+ih) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . src(1-ih:np+ih, 1-ih:mp+ih, l-1), . tmp(1-ih:np+ih, 1-ih:mp+ih) #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt compute absorbers at x boundaries if ( irlx.eq.1 ) then toliL=1./towxL toliR=1./towxR do j=1,mp xab1=xr1(j)*xc1(j)+dxabL !VEC xab1=xcr(1,j)*cosa(1,j)+dxabL xab2=xr2(j)*xc2(j)-dxabR !VEC xab2=xcr(n,j)*cosa(n,j)-dxabR do i=1,np ia=(npos-1)*np + i r0=xcr(i,j)*cosa(i,j) r1=amax1(0., xab1-r0)/dxabL r2=amax1(0., r0-xab2)/dxabR relb=toliL*r1+toliR*r2-2.*toliL*toliR*r1*r2/(toliL+toliR) tmp(i,j)=irlx*relb relx(i,j)=tmp(i,j) enddo enddo #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcx.eq.1) then call updatelr(tmp,np,mp,1,np,mp,1) do j=1,mp relx(np,j)=tmp(np+1,j) enddo endif endif #endif else do j=1,mp do i=1,np relx(i,j)=0. enddo enddo endif compute absorbers at y boundaries if (j3.eq.1) then c --- special explicit polar damping tolip=1./towyp do k=1,l dyagm = dyabp*gmm(1,1,k) do j=1,mp do i=1,np c yab1=yr1(i)+dyabp !VEC yab1=ycr(i,1 )+dyabp c yab2=yr2(i)-dyabp !VEC yab2=ycr(i,mp)-dyabp yab1=yr1(i)+dyagm !VEC yab1=ycr(i,1 )+dyabp yab2=yr2(i)-dyagm !VEC yab2=ycr(i,mp)-dyabp r0=ycr(i,j) c r1=amax1(0.,-r0+yab1)/dyabp c r2=amax1(0., r0-yab2)/dyabp r1=amax1(0.,-r0+yab1)/dyagm r2=amax1(0., r0-yab2)/dyagm relb=r1+r2-r1*r2 ! linear absorber c --- increases more rapidly as pole is approached c relb=(r1+r2-r1*r2)**2 ! inverse quadratic c relb=(r1+r2-r1*r2)**3 ! inverse cubic c relb=(r1+r2-r1*r2)**4 ! inverse quartic c --- levels off as pole is approached c relb=r1*(2.-r1)+r2*(2.-r2)-(r1*r2)**2-2.*r1*r2 ! quadratic c tmp(i,j)=isphere*relb*tolip c relpol(i,j)=tmp(i,j) relpol(i,j,k)=isphere*relb*tolip enddo enddo enddo if (irly.eq.1) then toli=1./towy do j=1,mp do i=1,np yab1=yr1(i)+dyab !VEC yab1=ycr(i,1 )+dyab yab2=yr2(i)-dyab !VEC yab2=ycr(i,mp)-dyab r0=ycr(i,j) r1=amax1(0.,-r0+yab1)/dyab r2=amax1(0., r0-yab2)/dyab relb=toli*(r1+r2-r1*r2) tmp(i,j)=irly*relb rely(i,j)=tmp(i,j) enddo enddo #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcy.eq.1) then call updatebt(tmp,np,mp,1,np,mp,1) do i=1,np rely(i,mp)=tmp(i,mp+1) enddo endif endif #endif else do j=1,mp do i=1,np rely(i,j)=0. enddo enddo endif endif c --- compute absorbers at upper boundary towi=1./towz select case(l) case(24) abscl=7.*dz/7. ! for negative zab !modif for different l case(47) abscl=14.*dz/7. ! for negative zab c abscl=dz case(93) abscl=28.*dz/7. ! for negative zab case(185) abscl=56.*dz/7. ! for negative zab endselect c abscl=14.*dz/3. ! for negative zab cc abscl=5.7e3 ! for negative zab do k=1,l zstr=fsi(z(k)) do j=1,mp do i=1,np zl=zstr/gi(i,j)+zs(i,j) if(zab.ge.0.) then c t1=iab*amax1(0.,zl-zab) c tau(k,i,j,1)=towi*t1/(zb-zab) c add absorber for stable layer under the SCZ c t11=iab*0.5*(tanh((k-20.)/6.)-1.) !l=185 c t11=iab*0.5*(tanh((k-10.)/3.)-1.) !l=93 t11=iab*0.5*(tanh((k-5.)/1.5)-1.) !l=47 tau(k,i,j,1)=-towi*t11 t2=iabth*amax1(0.,zl-zab) c data zab ,towz /-2.4053125e8,0.2592E+06/ !zab=(l-6)*dz00 c tau(k,i,j,2)=towi*t2/(zb-zab) tau(k,i,j,2)=tau(k,i,j,1) else c tau(k,i,j,1)=iab*towi*exp((zl-zb)/abscl) c tau(k,i,j,2)=iabth*towi*exp((zl-zb)/abscl) tau(k,i,j,2)=iabb*towi*exp((zl-zb)/abscl) tau(k,i,j,1)= iab*towi*exp(-zl/abscl) c tau(k,i,j,2)=iabth*towi*exp(-zl/abscl) endif end do end do end do return end subroutine galin(a,del) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(51) #endif do k=1,l do j=1,mp do i=1,np a(i,j,k)=a(i,j,k)+del end do end do end do call update(a,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(51) #endif return end subroutine thprof(th0,z,l,lipps) c --- anelastic potential temperature profile dimension th0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 if(lipps.eq.0) then ! Boussinesq profile do k=1,l c th0(k)=th00-g*z(k)/rg ! CAUTION: max. alt. exists th0(k)=th00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l th0(k)=th00 end do endif if(lipps.eq.2) then ! Clark-Farley profile do k=1,l th0(k)=th00*exp(st*z(k)) end do endif if(lipps.eq.3) then ! Bacmeister-Schoeberl profile do k=1,l th0(k)=th00*exp(st*z(k)) end do endif return end subroutine tprof(t0,z,l,lipps) c --- anelastic temperature profile dimension rh0(l),t0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO endif return end subroutine pprof(p0,z,l,lipps) c --- anelastic reference pressure profile dimension rh0(l),t0(l),p0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) p0(l1) = rg*t0(l1)*rh0(l1) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) p0(k) = rg*t0(k)*rh0(k) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) p0(k) = rg*t0(k)*rh0(k) END DO endif return end subroutine rhprof(rh0,z,l,lipps) c --- anelastic density profile dimension rh0(l),t0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO endif if(lipps.eq.2) then ! Clark-Farley profile capi=1./cap cs=g/(cp*tt00*st) do k=1,l exs=exp(-st*z(k)) ! CAUTION: max. alt. exists rh0(k)=rh00*exs*(1.-cs*(1.-exs))**(capi-1.) end do endif if(lipps.eq.3) then ! Bacmeister-Schoeberl profile sdi=1./6622.51 ! density scale height (m^-1) do k=1,l rh0(k)=rh00*exp(-sdi*z(k)) end do endif return end subroutine lstsq(th,z,nz,a,b) include 'param.nml' include 'msg.inc' dimension th(nz),z(nz) common/lsty/ y(l) sy=0 sz=0 syz=0 szz=0 do k=1,nz y(k)=alog(th(k)) end do do k=1,nz sz = sz + z(k) szz = szz + z(k)*z(k) syz = syz + y(k)*z(k) sy = sy + y(k) end do a=(sy*szz-sz*syz)/(float(nz)*szz-sz*sz) b=(float(nz)*syz-sy*sz)/(float(nz)*szz-sz*sz) a=exp(a) return end subroutine rhngck(rho) include 'param.nml' include 'msg.inc' dimension rho(1-ih:np+ih, 1-ih:mp+ih, l) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) real globmax,globmin #if (TIMEPLT == 1) call ttbeg(22) #endif checks for negative density in the profile rhmn= 1.e15 rhmx=-1.e15 rhsmn= 1.e15 rhsmx=-1.e15 do 26 k=1,l do 26 j=1,mp do 26 i=1,np dnm=stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j) rhophy=rho(i,j,k)*(gi(i,j)*gmus(k)) + /((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnm rhmx=amax1(rhmx,rhophy) rhmn=amin1(rhmn,rhophy) rhsmx=amax1(rhsmx,rho(i,j,k)) rhsmn=amin1(rhsmn,rho(i,j,k)) if(rho(i,j,k).lt.0.) print *,'rho<0',mype,i,j,k,rho(i,j,k), . stryy(i,j),strxx(i,j),stryx(i,j),strxy(i,j),rho(i,j,k),gi(i,j), . gmm(i,j,k),cosa(i,j) 26 continue rhmx=globmax(rhmx,1,1,1,1,1,1,1,1,1,1,1,1) rhmn=globmin(rhmn,1,1,1,1,1,1,1,1,1,1,1,1) rhsmx=globmax(rhsmx,1,1,1,1,1,1,1,1,1,1,1,1) rhsmn=globmin(rhsmn,1,1,1,1,1,1,1,1,1,1,1,1) if (mype.eq.0) then print 266, rhmn,rhmx ! physical density extrema print 267, rhsmn,rhsmx ! density*Jacobian extrema if(rhmn.le.0.) stop 'rho(z).le.0, consider exp. density profile' end if 266 format(2x,' rhmin, rhmx:',2e11.4) 267 format(2x,'rhsmin, rhsmx:',2e11.4) #if (TIMEPLT == 1) call ttend(22) #endif return end subroutine teprof(pm0,tm0,z,l,lipps) c --- anelastic pressure and temperature profiles c (only called if MOISTMOD > 0) dimension pm0(l),tm0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z if(lipps.eq.0) then ! Boussinesq profile do k=1,l pm0(k)=pr00-rh00*g*z(k) ! CAUTION: max. alt. exists tm0(k)=tt00-g*z(k)/rg ! CAUTION: max. alt. exists end do end if if(lipps.eq.1) then ! Ogura-Phillips profile capi=1./cap sdi=1./7000. ! density scale height (m^-1) do k=1,l pm0(k)=pr00*(1.-cap*z(k)*sdi)**capi ! CAUTION: max. alt. exists tm0(k)=tt00*(1.-cap*z(k)*sdi) ! CAUTION: max. alt. exists end do end if if(lipps.eq.2) then ! Clark-Farley profile capi=1./cap cs=g/(cp*tt00*st) do k=1,l exs=exp(-st*z(k)) pm0(k)=pr00*(1.-cs*(1.-exs))**capi ! CAUTION: max. alt. exists tm0(k)=tt00/exs*(1.-cs*(1.-exs)) ! CAUTION: max. alt. exists end do end if if(lipps.eq.3) then ! Bacmeister-Schoeberl profile sdi=1./7000. ! density scale height (m^-1) do k=1,l pm0(k)=pr00*exp(-sdi*z(k)) tm0(k)=pr00/(rg*rh00) end do end if return end subroutine rhotad(f,d,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(23) #endif if(iflg.eq.1) then do k=1,l do j=1,mp do i=1,np f(i,j,k)=f(i,j,k)*d(i,j,k) enddo enddo enddo endif if(iflg.eq.-1) then do k=1,l do j=1,mp do i=1,np f(i,j,k)=f(i,j,k)/d(i,j,k) enddo enddo enddo endif #if (TIMEPLT == 1) call ttend(23) #endif return end #if (ANALIZE == 0) subroutine bbc include 'param.nml' include 'msg.inc' common/rigidB/ bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) C---------------------------------------------------------------------------- C This routine sets the boundary conditions for normal induction B C at the model boundaries (cf. routine velbc for velocities) C There is no universal way to do this. Consider that C B_solenoidal= [Metric-Coefficient Matrix]*B_physical. C In the code below vertical-boundary solenoidal velocity is set assuming C that at the curvilinear boundary B_physical = B_environment, C but anything desired can be passed by the subroutine call. C---------------------------------------------------------------------------- do 3200 k=1,l,l-1 kk=1+k/l do 320 j=1,mp do 320 i=1,np g33=gi(i,j)*gmus(k) g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 bbz(i,j,kk)=g13*bxe(i,j,k)+g23*bye(i,j,k)+g33*bze(i,j,k) 320 continue 3200 continue do k=1,l do j=1,mp bbx(j,k,1)=0. bbx(j,k,2)=0. enddo do i=1,np bby(i,k,1)=0. bby(i,k,2)=0. enddo enddo if (leftedge.eq.1) then do 321 k=1,l do 321 j=1,mp ja=(mpos-1)*mp + j g110w=1./(gmm(1,j,k)*cosa(1,j)) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bbx(j,k,1)=g11w*bxe(1,j,k)+g21w*bye(1,j,k) #if (PARALLEL > 0) g110w=1./(gmm(0,j,k)*cosa(0,j)) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bbx(j,k,2)=g11w*bxe(0,j,k)+g21w*bye(0,j,k) #endif 321 continue end if if (rightedge.eq.1) then do 322 k=1,l do 322 j=1,mp ja=(mpos-1)*mp + j #if (PARALLEL > 0) g110e=1./(gmm(np+1,j,k)*cosa(np+1,j)) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bbx(j,k,1)=g11e*bxe(np+1,j,k)+g21e*bye(np+1,j,k) #endif g110e=1./(gmm(np,j,k)*cosa(np,j)) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bbx(j,k,2)=g11e*bxe(np,j,k)+g21e*bye(np,j,k) 322 continue end if if (botedge.eq.1) then do 323 k=1,l do 323 i=1,np g110s=1./(gmm(i,1,k)*cosa(i,1)) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bby(i,k,1)=g12s*bxe(i,1,k)+g22s*bye(i,1,k) #if (PARALLEL > 0) g110s=1./(gmm(i,0,k)*cosa(i,0)) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bby(i,k,2)=g12s*bxe(i,0,k)+g22s*bye(i,0,k) #endif 323 continue end if if (topedge.eq.1) then do 324 k=1,l do 324 i=1,np #if (PARALLEL > 0) g110n=1./(gmm(i,mp+1,k)*cosa(i,mp+1)) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bby(i,k,1)=g12n*bxe(i,mp+1,k)+g22n*bye(i,mp+1,k) #endif g110n=1./(gmm(i,mp,k)*cosa(i,mp)) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bby(i,k,2)=g12n*bxe(i,mp,k)+g22n*bye(i,mp,k) 324 continue end if call bbcad(bbx,bby,bbz,rh0) return end subroutine bbcad(bbx,bby,bbz,d) include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) dimension bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr13(1-ih:np+ih, 1-ih:mp+ih, l, 13), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) real globsum c#if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) c#endif c if((ibcx.eq.1).and.(ibcy.eq.1.or.j3.eq.0)) return #if (TIMEPLT == 1) call ttbeg(25) #endif c#if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=1 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pp(bbx(j,k,2))-d(np+1,j,k)*pn(bbx(j,k,1))) tmp2(2,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pn(bbx(j,k,2))-d(np+1,j,k)*pp(bbx(j,k,1))) tmp3(3,j,k)=wgz(k)*wgy(j)*(d(np,j,k)+d(np+1,j,k)) end do end do end if uout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) uinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pp(bby(i,k,2))-d(i,mp+1,k)*pn(bby(i,k,1))) tmp2(i,2,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pn(bby(i,k,2))-d(i,mp+1,k)*pp(bby(i,k,1))) tmp3(i,3,k)=wgz(k)*wgx(i)*(d(i,mp,k) + d(i,mp+1,k)) end do end do end if vout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np if ((ibbl .eq. 1) .and. (ibbu .eq. 1)) then tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (d(i,j,l)*pp(bbz(i,j,2))-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (d(i,j,l)*pn(bbz(i,j,2))-d(i,j,1)*pp(bbz(i,j,1))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) elseif (ibbl .eq. 1) then tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (-d(i,j,1)*pp(bbz(i,j,1))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,1)) else tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (d(i,j,l)*pp(bbz(i,j,2))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (d(i,j,l)*pn(bbz(i,j,2))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)) endif end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) else ! Bench do k=1,l do j=1,mp do i=1,np tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. end do end do end do do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) tmp1(i,j,1) = wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy tflx=tflx*dx*dy constant of mass adjustement c if(uout+vout+oout.eq.0.) iflg=1 c epsia=0. c if(iflg.eq.0) then c epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) c else epsim=1. epsiat=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) epsiab=-epsiat if (ibbl .eq. 0.) then epsiab = 0. endif if (ibbu .eq. 0.) then epsiat = 0. endif c endif corrected outflow velocities if(ibcx.eq.1) goto 111 if (leftedge.eq.1) then do 11 k=1,l do 11 j=1,mp 11 bbx(j,k,1)=pp(bbx(j,k,1))+epsim*pn(bbx(j,k,1))+epsiab endif if(rightedge.eq.1) then do 12 k=1,l do 12 j=1,mp 12 bbx(j,k,2)=pn(bbx(j,k,2))+epsim*pp(bbx(j,k,2))+epsiat endif 111 continue if(ibcy.eq.1) goto 222 if (botedge.eq.1) then do 22 k=1,l do 22 i=1,np 22 bby(i,k,1)=pp(bby(i,k,1))+epsim*pn(bby(i,k,1))+epsiab endif if (topedge.eq.1) then do 23 k=1,l do 23 i=1,np 23 bby(i,k,2)=pn(bby(i,k,2))+epsim*pp(bby(i,k,2))+epsiat endif 222 continue do j=1,mp do i=1,np bbz(i,j,2)=pn(bbz(i,j,2))+epsim*pp(bbz(i,j,2))+epsiat bbz(i,j,1)=pp(bbz(i,j,1))+epsim*pn(bbz(i,j,1))+epsiab enddo enddo c#endif ! Check it out oout=0. oinf=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp1(i,j,1)=wgx(i)*wgy(j)* . (d(i,j,l)*pp(bbz(i,j,2))-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* . (d(i,j,l)*pn(bbz(i,j,2))-d(i,j,1)*pp(bbz(i,j,1))) end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine velbc(ue,ve,rho) cc transform physical velocity bc (here ue,ve) to solenoidal velocities include 'param.nml' include 'msg.inc' dimension ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(24) #endif C---------------------------------------------------------------------------- C This routine sets the boundary conditions for normal solenoidal C velocities at the model boundaries. There is no universal way to C do this. There are two important formulae to consider: C a) V_solenoidal=V_contravariant- partial X_bar/partial t C b) V_solenoidal= [Metric-Coefficient Matrix]*V_physical. C Both are equivalent but their relative utility depends on the C problem at hand. C C In the code below vertical-boundary solenoidal velocity is set assuming C that the curvilinear boundary is impermeable, whereupon contravariant C velocity vanishes there (fluid adheres to the boundary), so relation (a) C is employed. Horizontal components exploit (b) formulae while assuming C known physical velocities at the boundary (here profiles ue and ve, C but anything desired can be passed by the subroutine call). Alternate C formulations are included (but commented out) for the use with special C applications (e.g., flow past chanels with vibrating lateral walls) C---------------------------------------------------------------------------- we =0. do 3200 k=1,l,l-1 kk=1+k/l do 320 j=1,mp do 320 i=1,np g33=gi(i,j)*gmus(k) ob(i,j,kk)=gmul(k)*zsd(i,j)/zb*g33-(gmul(k)/zb-1.)*zhd(i,j)*g33 !(a) C g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) C g220=1./gmm(i,j,k) C g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 C g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 C ob(i,j,kk)=g13*ue(i,j,k)+g23*ve(i,j,k)+g33*we !alternative (b) 320 continue 3200 continue do k=1,l do j=1,mp ub(j,k,1)=0. ub(j,k,2)=0. enddo do i=1,np vb(i,k,1)=0. vb(i,k,2)=0. enddo enddo if (leftedge.eq.1) then do 321 k=1,l do 321 j=1,mp ja=(mpos-1)*mp + j g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w ub(j,k,1)=g11w*ue(1,j,k)+g21w*ve(1,j,k) C ub(j,k,1)=-strxd(1,j) !alternative (a) #if (PARALLEL > 0) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w ub(j,k,2)=g11w*ue(0,j,k)+g21w*ve(0,j,k) C ub(j,k,2)=-strxd(0,j) !alternative (a) #endif 321 continue end if if (rightedge.eq.1) then do 322 k=1,l do 322 j=1,mp ja=(mpos-1)*mp + j #if (PARALLEL > 0) g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j) . +icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e ub(j,k,1)=g11e*ue(np+1,j,k)+g21e*ve(np+1,j,k) C ub(j,k,1)=-strxd(np+1,j) !alternative (a) #endif g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e ub(j,k,2)=g11e*ue(np,j,k)+g21e*ve(np,j,k) C ub(j,k,2)=-strxd(np,j) !alternative (a) 322 continue end if if (botedge.eq.1) then do 323 k=1,l do 323 i=1,np g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s vb(i,k,1)=g12s*ue(i,1,k)+g22s*ve(i,1,k) C vb(i,k,1)=-stryd(i,1) !alternative (a) #if (PARALLEL > 0) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s vb(i,k,2)=g12s*ue(i,0,k)+g22s*ve(i,0,k) C vb(i,k,2)=-stryd(i,0) !alternative (a) #endif 323 continue end if if (topedge.eq.1) then do 324 k=1,l do 324 i=1,np #if (PARALLEL > 0) g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n vb(i,k,1)=g12n*ue(i,mp+1,k)+g22n*ve(i,mp+1,k) C vb(i,k,1)=-stryd(i,mp+1) !alternative (a) #endif g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n vb(i,k,2)=g12n*ue(i,mp,k)+g22n*ve(i,mp,k) C vb(i,k,2)=-stryd(i,mp) !alternative (a) 324 continue end if #if (TIMEPLT == 1) call ttend(24) #endif call vbcad(rho) return end subroutine vbcad(d) include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr13(1-ih:np+ih, 1-ih:mp+ih, l, 13), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) real globsum #if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) #endif if((ibcx.eq.1).and.(ibcy.eq.1.or.j3.eq.0)) return #if (TIMEPLT == 1) call ttbeg(25) #endif #if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=0 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pp(ub(j,k,2))-d(np+1,j,k)*pn(ub(j,k,1))) tmp2(2,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pn(ub(j,k,2))-d(np+1,j,k)*pp(ub(j,k,1))) tmp3(3,j,k)=wgz(k)*wgy(j)*(d(np,j,k)+d(np+1,j,k)) end do end do end if uout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) uinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pp(vb(i,k,2))-d(i,mp+1,k)*pn(vb(i,k,1))) tmp2(i,2,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pn(vb(i,k,2))-d(i,mp+1,k)*pp(vb(i,k,1))) tmp3(i,3,k)=wgz(k)*wgx(i)*(d(i,mp,k) + d(i,mp+1,k)) end do end do end if vout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp1(i,j,1)=wgx(i)*wgy(j)* . (d(i,j,l)*pp(ob(i,j,2))-d(i,j,1)*pn(ob(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* . (d(i,j,l)*pn(ob(i,j,2))-d(i,j,1)*pp(ob(i,j,1))) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. end do end do end do do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) tmp1(i,j,1) = wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy tflx=tflx*dx*dy constant of mass adjustement if(uout+vout+oout.eq.0.) iflg=1 epsia=0. if(iflg.eq.0) then epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) else epsim=1. epsia=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) endif corrected outflow velocities if(ibcx.eq.1) goto 111 if (leftedge.eq.1) then do 11 k=1,l do 11 j=1,mp 11 ub(j,k,1)=pp(ub(j,k,1))+epsim*pn(ub(j,k,1))-epsia endif if(rightedge.eq.1) then do 12 k=1,l do 12 j=1,mp 12 ub(j,k,2)=pn(ub(j,k,2))+epsim*pp(ub(j,k,2))+epsia endif 111 continue if(ibcy.eq.1) goto 222 if (botedge.eq.1) then do 22 k=1,l do 22 i=1,np 22 vb(i,k,1)=pp(vb(i,k,1))+epsim*pn(vb(i,k,1))-epsia endif if (topedge.eq.1) then do 23 k=1,l do 23 i=1,np 23 vb(i,k,2)=pn(vb(i,k,2))+epsim*pp(vb(i,k,2))+epsia endif 222 continue c do 33 j=1,mp c do 33 i=1,np c ob(i,j,2)=pn(ob(i,j,2))+epsim*pp(ob(i,j,2))+epsia c 33 ob(i,j,1)=pp(ob(i,j,1))+epsim*pn(ob(i,j,1))-epsia #endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine vbcadn(d) c --- computes fluxes through non-periodic boundaries and corrects c --- boundary conditions to maintain global mass balance. include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . scr16(1-ih:np+ih, 1-ih:mp+ih, l-1), . temp(1-ih:np+ih, 1-ih:mp+ih) real globsum #if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) #endif if(ibcx.eq.1.and.ibcy.eq.1) return #if (TIMEPLT == 1) call ttbeg(25) #endif #if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=0 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 if (rightedge.eq.1) then do k=1,l do j=1,mp uout=uout+wgz(k)*wgy(j)* . (d(np,j,k)*pp(ub(j,k,2))-d(1,j,k)*pn(ub(j,k,1))) uinf=uinf+wgz(k)*wgy(j)* . (d(np,j,k)*pn(ub(j,k,2))-d(1,j,k)*pp(ub(j,k,1))) udb = udb+wgz(k)*wgy(j)*(d(np,j,k)+d(1,j,k)) end do end do end if #if (PARALLEL > 0) uout=globsum(uout,1,1,1,1,1,1,1,1,1,1,1,1) uinf=globsum(uinf,1,1,1,1,1,1,1,1,1,1,1,1) udb=globsum( udb,1,1,1,1,1,1,1,1,1,1,1,1) #endif udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 if (topedge.eq.1) then do k=1,l do i=1,np vout=vout+wgz(k)*wgx(i)* . (d(i,mp,k)*pp(vb(i,k,2))-d(i,1,k)*pn(vb(i,k,1))) vinf=vinf+wgz(k)*wgx(i)* . (d(i,mp,k)*pn(vb(i,k,2))-d(i,1,k)*pp(vb(i,k,1))) vdb = vdb+wgz(k)*wgx(i)*(d(i,mp,k)+d(i,1,k)) end do end do end if #if (PARALLEL > 0) vout=globsum(vout,1,1,1,1,1,1,1,1,1,1,1,1) vinf=globsum(vinf,1,1,1,1,1,1,1,1,1,1,1,1) vdb=globsum( vdb,1,1,1,1,1,1,1,1,1,1,1,1) #endif vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do j=1,mp do i=1,np oout=oout+wgx(i)*wgy(j)* . (d(i,j,l)*pp(ob(i,j,2))-d(i,j,1)*pn(ob(i,j,1))) oinf=oinf+wgx(i)*wgy(j)* . (d(i,j,l)*pn(ob(i,j,2))-d(i,j,1)*pp(ob(i,j,1))) odb = odb+wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do #if (PARALLEL > 0) oout=globsum(oout,1,1,1,1,1,1,1,1,1,1,1,1) oinf=globsum(oinf,1,1,1,1,1,1,1,1,1,1,1,1) odb=globsum( odb,1,1,1,1,1,1,1,1,1,1,1,1) #endif odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy endif do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) temp(i,j)=wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1) tflx=tflx*dx*dy constant of mass adjustement if(uout+vout+oout.eq.0.) iflg=1 if(iflg.eq.0) then epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) epsia=0. else epsim=1. epsia=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) endif corrected outflow velocities if(ibcx.eq.1) goto 111 do 11 k=1,l do 11 j=1,mp ub(j,k,2)=pn(ub(j,k,2))+epsim*pp(ub(j,k,2))+epsia 11 ub(j,k,1)=pp(ub(j,k,1))+epsim*pn(ub(j,k,1))-epsia 111 continue if(ibcy.eq.1) goto 222 do 22 k=1,l do 22 i=1,np vb(i,k,2)=pn(vb(i,k,2))+epsim*pp(vb(i,k,2))+epsia 22 vb(i,k,1)=pp(vb(i,k,1))+epsim*pn(vb(i,k,1))-epsia 222 continue c do 33 j=1,mp c do 33 i=1,np c ob(i,j,2)=pn(ob(i,j,2))+epsim*pp(ob(i,j,2))+epsia c 33 ob(i,j,1)=pp(ob(i,j,1))+epsim*pn(ob(i,j,1))-epsia #endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine velprd(u,v,w,ox,oy,oz,fox,foy,foz,p, . gc1,gc2,gc3,itraj1,eppr,itpr) c --- computes extrapolated fields at n+1 c --- computes staggered velocities and fluxes for advective solver include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . v(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . w(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . ox(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . oy(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . oz(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . p(1-ih:np+ih, 1-ih:mp+ih, l) c lc=0 or 1 ---> advecting velocities or velocites +0.5dtF in SL-like manner c io=0 or 1 ---> advecting physical or advective velocities c icont0=0 or 1; 0 shutts off auxiliary pressure solver for itraj=1 parameter(lc=1,io=0,iw=1-io,icont0=1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/slt/ x0(1-ih:np+ih,1-ih:mp+ih,l), 1 y0(1-ih:np+ih,1-ih:mp+ih,l), 1 z0(1-ih:np+ih,1-ih:mp+ih,l), 1 pfx(1-ih:np+ih,1-ih:mp+ih,l), 1 pfy(1-ih:np+ih,1-ih:mp+ih,l), 1 pfz(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) common/blank/ ux(1-ih:np+ih,1-ih:mp+ih,l), . uy(1-ih:np+ih,1-ih:mp+ih,l), . uz(1-ih:np+ih,1-ih:mp+ih,l), . vx(1-ih:np+ih,1-ih:mp+ih,l), . vy(1-ih:np+ih,1-ih:mp+ih,l), . vz(1-ih:np+ih,1-ih:mp+ih,l), . wx(1-ih:np+ih,1-ih:mp+ih,l), . wy(1-ih:np+ih,1-ih:mp+ih,l), . wz(1-ih:np+ih,1-ih:mp+ih,l), . temp(1-ih:np+ih,1-ih:mp+ih,l, 7) dimension wk0(0-ih:np+ih+1,0-ih:mp+ih+1,0:l+1) ! local array dimension wk1(1-ih:np+ih+1,1-ih:mp+ih+1,1:l+1) ! local array parameter(ialff=0) c return #if (TIMEPLT == 1) call ttbeg(39) #endif IF(ITRAJ1.EQ.0) THEN c --- do linear extrapolation to time level n+1 do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=2.*ox(i,j,k,0)*(lagr+ieul*d(i,j,k))-ox(i,j,k,2) oy(i,j,k,1)=2.*oy(i,j,k,0)*(lagr+ieul*d(i,j,k))-oy(i,j,k,2) oz(i,j,k,1)=2.*oz(i,j,k,0)*(lagr+ieul*d(i,j,k))-oz(i,j,k,2) u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) enddo enddo enddo if(ialff.eq.1) call trnsav(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1), * wx,wy,wz,j3,ibcx,ibcy,ibcz) ELSE do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,0)+0.5*dt*(fox(i,j,k)-ox(i,j,k,1)) oy(i,j,k,1)=oy(i,j,k,0)+0.5*dt*(foy(i,j,k)-oy(i,j,k,1)) oz(i,j,k,1)=oz(i,j,k,0)+0.5*dt*(foz(i,j,k)-oz(i,j,k,1)) enddo enddo enddo if(ieul.eq.0) go to 777 do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,0)+0.5*dt*(fx(i,j,k)-u(i,j,k,1)) v(i,j,k,1)=v(i,j,k,0)+0.5*dt*(fy(i,j,k)-v(i,j,k,1)) w(i,j,k,1)=w(i,j,k,0)+0.5*dt*(fz(i,j,k)-w(i,j,k,1)) ox(i,j,k,1)=io*ox(i,j,k, 1)+iw*u(i,j,k, 1) oy(i,j,k,1)=io*oy(i,j,k, 1)+iw*v(i,j,k, 1) oz(i,j,k,1)=io*oz(i,j,k, 1)+iw*w(i,j,k, 1) ox(i,j,k,2)=io*ox(i,j,k,lc)+iw*u(i,j,k,lc) oy(i,j,k,2)=io*oy(i,j,k,lc)+iw*v(i,j,k,lc) oz(i,j,k,2)=io*oz(i,j,k,lc)+iw*w(i,j,k,lc) enddo enddo enddo compute velocity derivatives call update2(ox(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) call update2(oy(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) call update2(oz(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim cp=.5*gc1*amax1(0.,ox(i,j,k,0)) cn=.5*gc1*amin1(0.,ox(i,j,k,0)) ux(i,j,k)= cp*(ox( i ,j,k,2)-ox(i-1,j,k,2)) . +cn*(ox(i+1,j,k,2)-ox( i ,j,k,2)) vx(i,j,k)= cp*(oy( i ,j,k,2)-oy(i-1,j,k,2)) . +cn*(oy(i+1,j,k,2)-oy( i ,j,k,2)) wx(i,j,k)= cp*(oz( i ,j,k,2)-oz(i-1,j,k,2)) . +cn*(oz(i+1,j,k,2)-oz( i ,j,k,2)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp c1p=.5*gc1*amax1(0.,ox(1,j,k,0)) c1n=.5*gc1*amin1(0.,ox(1,j,k,0)) ux(1,j,k)= c1n*(ox(2,j,k,2)-ox( 1,j,k,2)) 1 +ibcx*c1p*(ox(1,j,k,2)-ox(-1,j,k,2)) vx(1,j,k)= c1n*(oy(2,j,k,2)-oy( 1,j,k,2)) 1 +ibcx*c1p*(oy(1,j,k,2)-oy(-1,j,k,2)) wx(1,j,k)= c1n*(oz(2,j,k,2)-oz( 1,j,k,2)) 1 +ibcx*c1p*(oz(1,j,k,2)-oz(-1,j,k,2)) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp cnp=.5*gc1*amax1(0.,ox(np,j,k,0)) cnn=.5*gc1*amin1(0.,ox(np,j,k,0)) ux(np,j,k)= cnp*(ox(np ,j,k,2)-ox(np-1,j,k,2)) 1 +ibcx*cnn*(ox(np+2,j,k,2)-ox(np ,j,k,2)) vx(np,j,k)= cnp*(oy(np ,j,k,2)-oy(np-1,j,k,2)) 1 +ibcx*cnn*(oy(np+2,j,k,2)-oy(np ,j,k,2)) wx(np,j,k)= cnp*(oz(np ,j,k,2)-oz(np-1,j,k,2)) 1 +ibcx*cnn*(oz(np+2,j,k,2)-oz(np ,j,k,2)) enddo enddo end if #endif if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np cp=0.5*gc2*amax1(0., oy(i,j,k,0)) cn=0.5*gc2*amin1(0., oy(i,j,k,0)) uy(i,j,k)= cp*(ox(i,j ,k,2)-ox(i,j-j3,k,2)) . +cn*(ox(i,j+j3,k,2)-ox(i,j ,k,2)) vy(i,j,k)= cp*(oy(i,j ,k,2)-oy(i,j-j3,k,2)) . +cn*(oy(i,j+j3,k,2)-oy(i,j ,k,2)) wy(i,j,k)= cp*(oz(i,j ,k,2)-oz(i,j-j3,k,2)) . +cn*(oz(i,j+j3,k,2)-oz(i,j ,k,2)) 2 continue #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np c1p=0.5*gc2*amax1(0., oy(i,1,k,0)) c1n=0.5*gc2*amin1(0., oy(i,1,k,0)) uy(i,1,k)= c1n*(ox(i,1+j3,k,2)-ox(i, 1,k,2)) 1 +ibcy*c1p*(ox(i,1 ,k,2)-ox(i,-j3,k,2)) vy(i,1,k)= c1n*(oy(i,1+j3,k,2)-oy(i, 1,k,2)) 1 +ibcy*c1p*(oy(i,1 ,k,2)-oy(i,-j3,k,2)) wy(i,1,k)= c1n*(oz(i,1+j3,k,2)-oz(i, 1,k,2)) 1 +ibcy*c1p*(oz(i,1 ,k,2)-oz(i,-j3,k,2)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np cmp=0.5*gc2*amax1(0., oy(i,mp,k,0)) cmn=0.5*gc2*amin1(0., oy(i,mp,k,0)) uy(i,mp,k)=cmp*(ox(i,mp ,k,2)-ox(i,mp-j3,k,2)) 1 +ibcy*cmn*(ox(i,mp+1+j3,k,2)-ox(i,mp ,k,2)) vy(i,mp,k)=cmp*(oy(i,mp ,k,2)-oy(i,mp-j3,k,2)) 1 +ibcy*cmn*(oy(i,mp+1+j3,k,2)-oy(i,mp ,k,2)) wy(i,mp,k)=cmp*(oz(i,mp ,k,2)-oz(i,mp-j3,k,2)) 1 +ibcy*cmn*(oz(i,mp+1+j3,k,2)-oz(i,mp ,k,2)) enddo enddo end if #else if (botedge.eq.1) then do k=1,l do i=1,np c1p=0.5*gc2*amax1(0., oy(i,1,k,0)) c1n=0.5*gc2*amin1(0., oy(i,1,k,0)) uy(i,1,k)= c1p*(ox(i,1 ,k,2)-pflip*ox(i,1-j3,k,2)) . +c1n*(ox(i,1+j3,k,2)- ox(i,1 ,k,2)) vy(i,1,k)= c1p*(oy(i,1 ,k,2)-pflip*oy(i,1-j3,k,2)) . +c1n*(oy(i,1+j3,k,2)- oy(i,1 ,k,2)) wy(i,1,k)= c1p*(oz(i,1 ,k,2)-oz(i,1-j3,k,2)) c wy(i,1,k)= c1p*(oz(i,1 ,k,2)-pflip*oz(i,1-j3,k,2)) . +c1n*(oz(i,1+j3,k,2)- oz(i,1 ,k,2)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np cmp=0.5*gc2*amax1(0., oy(i,mp,k,0)) cmn=0.5*gc2*amin1(0., oy(i,mp,k,0)) uy(i,mp,k)= cmp*( ox(i,mp ,k,2)-ox(i,mp-j3,k,2)) . +cmn*(pflip*ox(i,mp+j3,k,2)-ox(i,mp ,k,2)) vy(i,mp,k)= cmp*( oy(i,mp ,k,2)-oy(i,mp-j3,k,2)) . +cmn*(pflip*oy(i,mp+j3,k,2)-oy(i,mp ,k,2)) wy(i,mp,k)= cmp*( oz(i,mp ,k,2)-oz(i,mp-j3,k,2)) . +cmn*(oz(i,mp+j3,k,2)-oz(i,mp ,k,2)) c . +cmn*(pflip*oz(i,mp+j3,k,2)-oz(i,mp ,k,2)) enddo enddo end if #endif else do k=1,l do j=1,mp do i=1,np uy(i,j,k)=0. vy(i,j,k)=0. wy(i,j,k)=0. enddo end do end do endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np cp=.5*gc3*amax1(0.,oz(i,j,k,0)) cn=.5*gc3*amin1(0.,oz(i,j,k,0)) uz(i,j,k)= cp*(ox(i,j, k ,2)-ox(i,j,k-1,2)) . +cn*(ox(i,j,k+1,2)-ox(i,j, k ,2)) vz(i,j,k)= cp*(oy(i,j, k ,2)-oy(i,j,k-1,2)) . +cn*(oy(i,j,k+1,2)-oy(i,j, k ,2)) wz(i,j,k)= cp*(oz(i,j, k ,2)-oz(i,j,k-1,2)) . +cn*(oz(i,j,k+1,2)-oz(i,j, k ,2)) 3 continue do j=1,mp do i=1,np c1p=.5*gc3*amax1(0.,oz(i,j,1,0)) c1n=.5*gc3*amin1(0.,oz(i,j,1,0)) clp=.5*gc3*amax1(0.,oz(i,j,l,0)) cln=.5*gc3*amin1(0.,oz(i,j,l,0)) uz(i,j,1)= c1n*(ox(i,j,2,2)-ox(i,j, 1 ,2)) 1 +ibcz*c1p*(ox(i,j,1,2)-ox(i,j,l-1,2)) uz(i,j,l)= clp*(ox(i,j,l,2)-ox(i,j,l-1,2)) 1 +ibcz*c1n*(ox(i,j,2,2)-ox(i,j, l ,2)) vz(i,j,1)= c1n*(oy(i,j,2,2)-oy(i,j, 1 ,2)) 1 +ibcz*c1p*(oy(i,j,1,2)-oy(i,j,l-1,2)) vz(i,j,l)= clp*(oy(i,j,l,2)-oy(i,j,l-1,2)) 1 +ibcz*c1n*(oy(i,j,2,2)-oy(i,j, l ,2)) wz(i,j,1)= c1n*(oz(i,j,2,2)-oz(i,j, 1 ,2)) 1 +ibcz*c1p*(oz(i,j,1,2)-oz(i,j,l-1,2)) wz(i,j,l)= clp*(oz(i,j,l,2)-oz(i,j,l-1,2)) 1 +ibcz*c1n*(oz(i,j,2,2)-oz(i,j, l ,2)) enddo enddo do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,1)-ux(i,j,k)-uy(i,j,k)-uz(i,j,k) oy(i,j,k,1)=oy(i,j,k,1)-vx(i,j,k)-vy(i,j,k)-vz(i,j,k) oz(i,j,k,1)=oz(i,j,k,1)-wx(i,j,k)-wy(i,j,k)-wz(i,j,k) enddo enddo enddo if(iw.eq.1) then do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k,2)=g11*ox(i,j,k,1)+g21*oy(i,j,k,1) oy(i,j,k,2)=g12*ox(i,j,k,1)+g22*oy(i,j,k,1) oz(i,j,k,2)=g13*ox(i,j,k,1)+g23*oy(i,j,k,1)+g33*oz(i,j,k,1) ox(i,j,k,1)=ox(i,j,k,2)+strxd(i,j) oy(i,j,k,1)=oy(i,j,k,2)+stryd(i,j) oz(i,j,k,1)=oz(i,j,k,2)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 enddo enddo enddo endif if(ialff.eq.1) call trnsav(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1), * wx,wy,wz,j3,ibcx,ibcy,ibcz) 777 continue continuity constraint imposed icont=icont0*itraj1 if(icont.eq.1) then do k=1,l do j=1,mp do i=1,np w(i,j,k,1)=0. ox(i,j,k,2)=1. oy(i,j,k,2)=0. oz(i,j,k,2)=1. u(i,j,k,1)=1. enddo enddo enddo if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1),1) store=initprs initprs=0 call gcrk(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), 1 ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), 1 u(1-ih,1-ih,1,1),ub,vb,ob,itpr,eppr,1,1) c 1 u(1-ih,1-ih,1,1),itpr,eppr,1) call prforc(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), 1 ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), 1 u(1-ih,1-ih,1,1),ub,vb,ob,1) c 1 u(1-ih,1-ih,1,1)) initprs=store do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=pfx(i,j,k) oy(i,j,k,1)=pfy(i,j,k) oz(i,j,k,1)=pfz(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1),-1) endif !end of auxuliary pr.solver do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) enddo enddo enddo ENDIF if(ieul.eq.1) then if(itraj1.eq.0) then do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=0.5*(ox(i,j,k,1)+ox(i,j,k,0)*d(i,j,k))*gc1 oy(i,j,k,1)=0.5*(oy(i,j,k,1)+oy(i,j,k,0)*d(i,j,k))*gc2 oz(i,j,k,1)=0.5*(oz(i,j,k,1)+oz(i,j,k,0)*d(i,j,k))*gc3 enddo enddo enddo else do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,1)*d(i,j,k)*gc1 oy(i,j,k,1)=oy(i,j,k,1)*d(i,j,k)*gc2 oz(i,j,k,1)=oz(i,j,k,1)*d(i,j,k)*gc3 enddo enddo enddo endif create staggered advective velocities for A or B grid ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatebt(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupy) do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.5*(oz(i,j,k,1)+oz(i,j,k-1,1)) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=ibcz*z0(i,j,l)+ibzo*(2.*oz(i,j,1,1)-z0(i,j,2)) wbc(i,j,2)=ibcz*z0(i,j,2)+ibzo*(2.*oz(i,j,l,1)-z0(i,j,l)) enddo enddo #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif do k=1,l do j=jllim,julim do i=1,np y0(i,j,k)=0.5*(oy(i,j,k,1)+oy(i,j-j3,k,1)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.1) then call updatebt(y0,np,mp,l,np,mp,2) if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=y0(i,0,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,2)=y0(i,mp+2*j3,k) end do end do end if else ! ibcy=0 if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=2.*oy(i,1,k,1)-y0(i,1+j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,2)=2.*oy(i,mp,k,1)-y0(i,mp,k) end do end do end if endif #else if ((botedge.eq.1).or.(topedge.eq.1)) then do k=1,l do i=1,np vbc(i,k,1)=0. vbc(i,k,2)=0. enddo enddo end if #endif #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim x0(i,j,k)=0.5*(ox(i,j,k,1)+ox(i-1,j,k,1)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then call updatelr(x0,np,mp,l,np,mp,2) if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=x0(0,j,k) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,2)=x0(np+2,j,k) enddo enddo end if else ! ibcx=0 if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=2.*ox(1,j,k,1)-x0(2,j,k) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,2)=2.*ox(np,j,k,1)-x0(np,j,k) enddo enddo end if endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge illim0= 1 - leftedge jllim0= 1 - j3*botedge iulim = np + rightedge julim = mp + j3*topedge iupwy = 1 + 2*ibcy n1=1 n2=np m1=1 m2=mp if ( leftedge.eq.1) n1=0 if (rightedge.eq.1) n2=np+1 if ( botedge.eq.1) m1=0 if ( topedge.eq.1) m2=mp+1 if(j3.eq.0) then ! <----------- 2D call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupy) CCCCCCCCCCCCC c: U velocity CCCCCCCCCCCCC do 40 k=1,l do 40 i=1,np 40 wk0(i,1,k)=ox(i,1,k,1) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*ox(-1,1,k,1)+ibxo*(2.*ox(1,1,k,1)-ox(2,1,k,1)) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)= . ibcx*ox(np+2,1,k,1)+ibxo*(2.*ox(np,1,k,1)-ox(np-1,1,k,1)) enddo endif do 42 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*wk0(i,1, 2 ) 42 wk0(i,1,l+1)=ibcz*wk0(i,1, 2 )+ibzo*wk0(i,1,l-1) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do i=illim,np x0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i,1,k+1)) enddo enddo if (leftedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(1,1,k)+wk1(1,1,k+1)) ubc(1,k,2)=0.5*(wk1(0,1,k)+wk1(0,1,k+1)) enddo endif if (rightedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(np+2,1,k)+wk1(np+2,1,k+1)) ubc(1,k,2)=0.5*(wk1(np+1,1,k)+wk1(np+1,1,k+1)) enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc CCCCCCCCCCCCC c: W velocity CCCCCCCCCCCCC do 50 k=1,l do 50 i=1,np 50 wk0(i,1,k)=oz(i,1,k,1) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*oz(-1,1,k,1)+ibxo*oz(2,1,k,1) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)=ibcx*oz(np+2,1,k,1)+ibxo*oz(np-1,1,k,1) enddo endif do 52 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*(2.*wk0(i,1,1)-wk0(i,1,2 )) 52 wk0(i,1,l+1)=ibcz*wk0(i,1,2 )+ibzo*(2.*wk0(i,1,l)-wk0(i,1,l-1)) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do i=1,np z0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i+1,1,k)) enddo enddo do i=1,np wbc(i,1,1)=0.5*(wk1(i,1, 1 )+wk1(i+1,1, 1 )) wbc(i,1,2)=0.5*(wk1(i,1,l+1)+wk1(i+1,1,l+1)) enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc else ! <----------- 3D call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oz(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) c: U velocity do 10 k=1,l do 10 j=1,mp do 10 i=1,np 10 wk0(i,j,k)=ox(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*ox(-1 ,j,k,1) * +ibxo*(2.*ox(1 ,j,k,1)-ox(2 ,j,k,1)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*ox(np+2,j,k,1) * +ibxo*(2.*ox(np,j,k,1)-ox(np-1,j,k,1)) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 13 j=jllim0,julim do 13 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 13 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do j=1,mp do i=illim,np x0(i,j,k)=0.25*( wk1(i,j ,k)+wk1(i,j ,k+1) . +wk1(i,j+j3,k)+wk1(i,j+j3,k+1) ) enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(1,j ,k)+wk1(1,j ,k+1) . +wk1(1,j+j3,k)+wk1(1,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(0,j ,k)+wk1(0,j ,k+1) . +wk1(0,j+j3,k)+wk1(0,j+j3,k+1) ) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(np+2,j ,k)+wk1(np+2,j ,k+1) . +wk1(np+2,j+j3,k)+wk1(np+2,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(np+1,j ,k)+wk1(np+1,j ,k+1) . +wk1(np+1,j+j3,k)+wk1(np+1,j+j3,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: V velocity do 20 k=1,l do 20 j=1,mp do 20 i=1,np 20 wk0(i,j,k)=oy(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oy(-1,j,k,1)+ibxo*oy(2,j,k,1) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oy(np+2,j,k,1)+ibxo*oy(np-1,j,k,1) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)= ibcy*wk0(i,-2-j3,k) . +ibyo*(2.*wk0(i,1,k)-wk0(i,1+j3,k)) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)= ibcy*wk0(i,mp+3+j3,k) . +ibyo*(2.*wk0(i,mp,k)-wk0(i,mp-j3,k)) enddo enddo endif do 23 j=jllim0,julim do 23 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 23 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid y velocities do k=1,l do j=jllim,mp do i=1,np y0(i,j,k)=0.25*( wk1(i ,j,k)+wk1(i ,j,k+1) . +wk1(i+1,j,k)+wk1(i+1,j,k+1) ) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,1,k)+wk1(i ,1,k+1) . +wk1(i+1,1,k)+wk1(i+1,1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,0,k)+wk1(i ,0,k+1) . +wk1(i+1,0,k)+wk1(i+1,0,k+1) ) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,mp+j3+1,k)+wk1(i ,mp+j3+1,k+1) . +wk1(i+1,mp+j3+1,k)+wk1(i+1,mp+j3+1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,mp+j3 ,k)+wk1(i ,mp+j3 ,k+1) . +wk1(i+1,mp+j3 ,k)+wk1(i+1,mp+j3 ,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: W velocity do 30 k=1,l do 30 j=1,mp do 30 i=1,np 30 wk0(i,j,k)=oz(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oz(-1,j,k,1)+ibxo*oz(2,j,k,1) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oz(np+2,j,k,1)+ibxo*oz(np-1,j,k,1) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 33 j=jllim0,julim do 33 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*(2.*wk0(i,j,1)-wk0(i,j, 2 )) 33 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*(2.*wk0(i,j,l)-wk0(i,j,l-1)) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.25*( wk1(i, j ,k)+wk1(i+1, j ,k) . +wk1(i,j+j3,k)+wk1(i+1,j+j3,k) ) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=0.25*( wk1(i, j ,1)+wk1(i+1, j ,1) . +wk1(i,j+j3,1)+wk1(i+1,j+j3,1) ) wbc(i,j,2)=0.25*( wk1(i, j ,l+1)+wk1(i+1, j ,l+1) . +wk1(i,j+j3,l+1)+wk1(i+1,j+j3,l+1) ) enddo enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc endif ! <----------- 2D,3D #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif ! <--- igrid endif ! <--- ieul = 1 if(lagr.eq.1) then call update(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update(oz(1-ih,1-ih,1,1),np,mp,l,np,mp,1) endif #if (TIMEPLT == 1) call ttend(39) #endif return end subroutine bvprd(u,v,w,ox,oy,oz) c --- computes extrapolated fields at n+1 c --- computes staggered velocities and fluxes for advective solver include 'param.nml' include 'msg.inc' dimension u(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . v(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . w(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . d(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/rigidB/ ob(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . ub(1-ih:mmhdp+ih, lmhd , 2), . vb(1-ih:nmhdp+ih, lmhd , 2) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) dimension wk0(0-ih:np+ih+1,0-ih:mp+ih+1,0:l+1) ! local array dimension wk1(1-ih:np+ih+1,1-ih:mp+ih+1,1:l+1) ! local array dimension p(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) ! local array common/mhdscr/ s1(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s2(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s3(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s4(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi icont=1 !mod bbc do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = w(i,j,2) bze(i,j,1) = w(i,j,2)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi bze(i,j,l-1) = w(i,j,l-1) bze(i,j,l) = w(i,j,l-1)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc do k=1,l do j=1,mp do i=1,np g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k)=g11*u(i,j,k)+g21*v(i,j,k) oy(i,j,k)=g12*u(i,j,k)+g22*v(i,j,k) oz(i,j,k)=g13*u(i,j,k)+g23*v(i,j,k)+g33*w(i,j,k) if(icont.eq.0) then ox(i,j,k)=ox(i,j,k)*d(i,j,k)*gc1 oy(i,j,k)=oy(i,j,k)*d(i,j,k)*gc2 oz(i,j,k)=oz(i,j,k)*d(i,j,k)*gc3 endif enddo enddo enddo IF(ICONT.EQ.1) THEN call rhoswap( 1) do k=1,l do j=1,mp do i=1,np p(i,j,k)=0. s1(i,j,k)=1. s2(i,j,k)=0. s3(i,j,k)=1. s4(i,j,k)=1. enddo enddo enddo c if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), c * oy(1-ih,1-ih,1,1), c * oz(1-ih,1-ih,1,1),1) initprst=initprs initprs=0 call gcrk( p,x0,y0,z0,ox,oy,oz,s1,s2,s3,s4,ub,vb,ob * ,90,1.e-5,1,2) call prforc(p,x0,y0,z0,ox,oy,oz,s1,s2,s3,s4,ub,vb,ob,2) initprs=initprst call rhoswap(-1) do k=1,l do j=1,mp do i=1,np ox(i,j,k)=x0(i,j,k) oy(i,j,k)=y0(i,j,k) oz(i,j,k)=z0(i,j,k) enddo enddo enddo c if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), c * oy(1-ih,1-ih,1,1), c * oz(1-ih,1-ih,1,1),-1) do k=1,l do j=1,mp do i=1,np ox(i,j,k)=ox(i,j,k)*d(i,j,k)*gc1 oy(i,j,k)=oy(i,j,k)*d(i,j,k)*gc2 oz(i,j,k)=oz(i,j,k)*d(i,j,k)*gc3 enddo enddo enddo ENDIF !end of auxuliary pr.solver Create staggered advective velocities for A or B grid ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatebt(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupy) do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.5*(oz(i,j,k)+oz(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=ibcz*z0(i,j,l)+ibzo*(2.*oz(i,j,1)-z0(i,j,2)) wbc(i,j,2)=ibcz*z0(i,j,2)+ibzo*(2.*oz(i,j,l)-z0(i,j,l)) enddo enddo #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif c jllim = 1 + j3*botedge !modpol do k=1,l c do j=jllim,mp do j=jllim,julim do i=1,np y0(i,j,k)=0.5*(oy(i,j,k)+oy(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) call update(y0,np,mp,l,np,mp,iup) if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=ibcy*y0(i,0 ,k)+ibyo*(2.*oy(i,1,k)-y0(i,1+j3,k)) vbc(i,k,2)=ibcy*y0(i,1+j3,k)+ibyo*(2.*oy(i,0,k)-y0(i,0 ,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=ibcy*y0(i,mp ,k)+ . ibyo*(2.*oy(i,mp+1,k)-y0(i,mp+1+j3,k)) vbc(i,k,2)=ibcy*y0(i,mp+1+j3,k)+ . ibyo*(2.*oy(i,mp ,k)-y0(i,mp ,k)) end do end do end if #else if ((botedge.eq.1).or.(topedge.eq.1)) then do k=1,l do i=1,np vbc(i,k,1)=0. vbc(i,k,2)=0. enddo enddo end if #endif #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c illim = 1 + leftedge do k=1,l do j=1,mp do i=illim,iulim c do i=illim,np x0(i,j,k)=0.5*(ox(i,j,k)+ox(i-1,j,k)) enddo enddo enddo #if (POLES == 0) call update(x0,np,mp,l,np,mp,iup) if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=ibcx*x0(0,j,k)+ibxo*(2.*ox(1,j,k)-x0(2,j,k)) ubc(j,k,2)=ibcx*x0(2,j,k)+ibxo*(2.*ox(0,j,k)-x0(0,j,k)) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=ibcx*x0(np ,j,k)+ibxo*(2.*ox(np+1,j,k)-x0(np+2,j,k)) ubc(j,k,2)=ibcx*x0(np+2,j,k)+ibxo*(2.*ox(np ,j,k)-x0(np ,j,k)) enddo enddo end if #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge illim0= 1 - leftedge jllim0= 1 - j3*botedge iulim = np + rightedge julim = mp + j3*topedge n1=1 n2=np m1=1 m2=mp if ( leftedge.eq.1) n1=0 if (rightedge.eq.1) n2=np+1 if ( botedge.eq.1) m1=0 if ( topedge.eq.1) m2=mp+1 if(j3.eq.0) then ! <----------- 2D call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupx) CCCCCCCCCCCCC c: U velocity CCCCCCCCCCCCC do 40 k=1,l do 40 i=1,np 40 wk0(i,1,k)=ox(i,1,k) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*ox(-1,1,k)+ibxo*(2.*ox(1,1,k)-ox(2,1,k)) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)= . ibcx*ox(np+2,1,k)+ibxo*(2.*ox(np,1,k)-ox(np-1,1,k)) enddo endif do 42 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*wk0(i,1, 2 ) 42 wk0(i,1,l+1)=ibcz*wk0(i,1, 2 )+ibzo*wk0(i,1,l-1) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupx) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,iupx) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do i=illim,np x0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i,1,k+1)) enddo enddo if (leftedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(1,1,k)+wk1(1,1,k+1)) ubc(1,k,2)=0.5*(wk1(0,1,k)+wk1(0,1,k+1)) enddo endif if (rightedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(np+2,1,k)+wk1(np+2,1,k+1)) ubc(1,k,2)=0.5*(wk1(np+1,1,k)+wk1(np+1,1,k+1)) enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc CCCCCCCCCCCCC c: W velocity CCCCCCCCCCCCC do 50 k=1,l do 50 i=1,np 50 wk0(i,1,k)=oz(i,1,k) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*oz(-1,1,k)+ibxo*oz(2,1,k) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)=ibcx*oz(np+2,1,k)+ibxo*oz(np-1,1,k) enddo endif do 52 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*(2.*wk0(i,1,1)-wk0(i,1,2 )) 52 wk0(i,1,l+1)=ibcz*wk0(i,1,2 )+ibzo*(2.*wk0(i,1,l)-wk0(i,1,l-1)) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupx) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,iupx) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do i=1,np z0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i+1,1,k)) enddo enddo do i=1,np wbc(i,1,1)=0.5*(wk1(i,1, 1 )+wk1(i+1,1, 1 )) wbc(i,1,2)=0.5*(wk1(i,1,l+1)+wk1(i+1,1,l+1)) enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc else ! <----------- 3D call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oz(1-ih,1-ih,1),np,mp,l,np,mp,iupx) c: U velocity do 10 k=1,l do 10 j=1,mp do 10 i=1,np 10 wk0(i,j,k)=ox(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*ox(-1 ,j,k) * +ibxo*(2.*ox(1 ,j,k)-ox(2 ,j,k)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*ox(np+2,j,k) * +ibxo*(2.*ox(np,j,k)-ox(np-1,j,k)) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 13 j=jllim0,julim do 13 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 13 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do j=1,mp do i=illim,np x0(i,j,k)=0.25*( wk1(i,j ,k)+wk1(i,j ,k+1) . +wk1(i,j+j3,k)+wk1(i,j+j3,k+1) ) enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(1,j ,k)+wk1(1,j ,k+1) . +wk1(1,j+j3,k)+wk1(1,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(0,j ,k)+wk1(0,j ,k+1) . +wk1(0,j+j3,k)+wk1(0,j+j3,k+1) ) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(np+2,j ,k)+wk1(np+2,j ,k+1) . +wk1(np+2,j+j3,k)+wk1(np+2,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(np+1,j ,k)+wk1(np+1,j ,k+1) . +wk1(np+1,j+j3,k)+wk1(np+1,j+j3,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: V velocity do 20 k=1,l do 20 j=1,mp do 20 i=1,np 20 wk0(i,j,k)=oy(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oy(-1,j,k)+ibxo*oy(2,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oy(np+2,j,k)+ibxo*oy(np-1,j,k) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)= ibcy*wk0(i,-2-j3,k) . +ibyo*(2.*wk0(i,1,k)-wk0(i,1+j3,k)) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)= ibcy*wk0(i,mp+3+j3,k) . +ibyo*(2.*wk0(i,mp,k)-wk0(i,mp-j3,k)) enddo enddo endif do 23 j=jllim0,julim do 23 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 23 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid y velocities do k=1,l do j=jllim,mp do i=1,np y0(i,j,k)=0.25*( wk1(i ,j,k)+wk1(i ,j,k+1) . +wk1(i+1,j,k)+wk1(i+1,j,k+1) ) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,1,k)+wk1(i ,1,k+1) . +wk1(i+1,1,k)+wk1(i+1,1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,0,k)+wk1(i ,0,k+1) . +wk1(i+1,0,k)+wk1(i+1,0,k+1) ) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,mp+j3+1,k)+wk1(i ,mp+j3+1,k+1) . +wk1(i+1,mp+j3+1,k)+wk1(i+1,mp+j3+1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,mp+j3 ,k)+wk1(i ,mp+j3 ,k+1) . +wk1(i+1,mp+j3 ,k)+wk1(i+1,mp+j3 ,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: W velocity do 30 k=1,l do 30 j=1,mp do 30 i=1,np 30 wk0(i,j,k)=oz(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oz(-1,j,k)+ibxo*oz(2,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oz(np+2,j,k)+ibxo*oz(np-1,j,k) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 33 j=jllim0,julim do 33 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*(2.*wk0(i,j,1)-wk0(i,j, 2 )) 33 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*(2.*wk0(i,j,l)-wk0(i,j,l-1)) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.25*( wk1(i, j ,k)+wk1(i+1, j ,k) . +wk1(i,j+j3,k)+wk1(i+1,j+j3,k) ) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=0.25*( wk1(i, j ,1)+wk1(i+1, j ,1) . +wk1(i,j+j3,1)+wk1(i+1,j+j3,1) ) wbc(i,j,2)=0.25*( wk1(i, j ,l+1)+wk1(i+1, j ,l+1) . +wk1(i,j+j3,l+1)+wk1(i+1,j+j3,l+1) ) enddo enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc endif ! <----------- 2D,3D #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif ! <--- igrid return end subroutine trnsav(ox,oy,oz,wx,wy,wz,j3,ibcx,ibcy,ibcz) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . wx(1-ih:np+ih, 1-ih:mp+ih, l), . wy(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(26) #endif ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif call updatelr(oz,np,mp,l,np,mp,iupx) call updatelr(oy,np,mp,l,np,mp,iupx) call updatebt(ox,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim wz(i,j,k)=.25*(oz(i+1,j,k)+2.*oz(i,j,k)+oz(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp wz(1,j,k)=.25*(oz(2,j,k)+2.*oz(1,j,k)+oz(-1,j,k))*ibcx * +oz(1,j,k)*ibxo enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp wz(np,j,k)=.25*(oz(np+2,j,k)+2.*oz(np,j,k)+oz(np-1,j,k))*ibcx * +oz(np,j,k)*ibxo enddo enddo end if #endif call updatebt(wz,np,mp,l,np,mp,iupy) do k=1,l do j=jllim,julim do i=1,np oz(i,j,k)=.25*(wz(i,j+j3,k)+2.*wz(i,j,k)+wz(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np oz(i,1,k)=.25*(wz(i,1+j3,k)+2.*wz(i,1,k)+wz(i,-j3,k))*ibcy * +wz(i,1,k)*ibyo enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np oz(i,mp,k)=.25*(wz(i,mp+1+j3,k)+2.*wz(i,mp,k)+wz(i,mp-j3,k))*ibcy * +wz(i,mp,k)*ibyo enddo enddo end if #endif do k=1,l do j=1,mp do i=illim,iulim wy(i,j,k)=.25*(oy(i+1,j,k)+2.*oy(i,j,k)+oy(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp wy(1,j,k)=.25*(oy(2,j,k)+2.*oy(1,j,k)+oy(-1,j,k))*ibcx * +oy( 1,j,k) *ibxo enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp wy(np,j,k)=.25*(oy(np+2,j,k)+2.*oy(np,j,k)+oy(np-1,j,k))*ibcx * +oy( np ,j,k) *ibxo enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np oy(i,j,k)=.25*(wy(i,j,k+1)+2.*wy(i,j,k)+wy(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np oy(i,j,1)=.25*(wy(i,j,2)+2.*wy(i,j,1)+wy(i,j,l-1))*ibcz * +wy(i,j, 1 ) *ibzo oy(i,j,l)=.25*(wy(i,j,2)+2.*wy(i,j,l)+wy(i,j,l-1))*ibcz * +wy(i,j, l ) *ibzo enddo enddo do k=1,l do j=jllim,julim do i=1,np wx(i,j,k)=.25*(ox(i,j+j3,k)+2.*ox(i,j,k)+ox(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np wx(i,1,k)=.25*(ox(i,1+j3,k)+2.*ox(i,1,k)+ox(i,-j3,k))*ibcy * +ox(i, 1,k) *ibyo enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np wx(i,mp,k)=.25*(ox(i,mp+1+j3,k)+2.*ox(i,mp,k)+ox(i,mp-j3,k))*ibcy * +ox(i,mp ,k) *ibyo enddo enddo end if #else if (botedge.eq.1) then do k=1,l do i=1,np wx(i,1,k)=.25*(ox(i,1+j3,k)+2.*ox(i,1,k)+pflip*ox(i,1-j3,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np wx(i,mp,k)=.25*(pflip*ox(i,mp+j3,k)+2.*ox(i,mp,k)+ox(i,mp-j3,k)) enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np ox(i,j,k)=.25*(wx(i,j,k+1)+2.*wx(i,j,k)+wx(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np ox(i,j,1)=.25*(wx(i,j,2)+2.*wx(i,j,1)+wx(i,j,l-1))*ibcz * +wx(i,j, 1 ) *ibzo ox(i,j,l)=.25*(wx(i,j,2)+2.*wx(i,j,l)+wx(i,j,l-1))*ibcz * +wx(i,j, l ) *ibzo enddo enddo #if (TIMEPLT == 1) call ttend(26) #endif return end #endif /* ANALIZE == 0 */ subroutine potprs(u,v,w,p) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real globsum,psum #if (TIMEPLT == 1) call ttbeg(27) #endif compute pressure from the potential psum=0. if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 p(i,j,k)=-.5*(u(i,j,k)**2+j3*v(i,j,k)**2+w(i,j,k)**2) c return psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) psum=psum/float(n*m*l) do 2 k=1,l do 2 j=1,mp do 2 i=1,np 2 p(i,j,k)=p(i,j,k)-psum cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) do 3 k=2,l do 3 j=jllim,mp do 3 i=illim,np uav=.125*( u(i ,j ,k )+u(i-1,j ,k ) 1 +u(i-1,j-j3,k )+u(i ,j-j3,k ) 1 +u(i ,j ,k-1)+u(i-1,j ,k-1) 1 +u(i-1,j-j3,k-1)+u(i ,j-j3,k-1) ) vav=.125*( v(i ,j ,k )+v(i-1,j ,k ) 1 +v(i-1,j-j3,k )+v(i ,j-j3,k ) 1 +v(i ,j ,k-1)+v(i-1,j ,k-1) 1 +v(i-1,j-j3,k-1)+v(i ,j-j3,k-1) )*j3 wav=.125*( w(i ,j ,k )+w(i-1,j ,k ) 1 +w(i-1,j-j3,k )+w(i ,j-j3,k ) 1 +w(i ,j ,k-1)+w(i-1,j ,k-1) 1 +w(i-1,j-j3,k-1)+w(i ,j-j3,k-1) ) 3 p(i,j,k)=-.5*(uav**2+vav**2+wav**2) psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np,jllim,mp,2,l) psum=psum/float((l-1)*(m-j3)*(n-1)) do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 p(i,j,k)=p(i,j,k)-psum #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif call update(p,np,mp,l,np,mp,1) if (mype.eq.0) print 100, psum 100 format(2x,'potential initialisation, psum=', e11.4) #if (TIMEPLT == 1) call ttend(27) #endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine reduce_sum(f,fav,tau,iflg) ! include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(m,l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . tmpyz(mp,l),fav(mp,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw mpl=m*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif #if(PARALLEL > 0) do k=1,l do j=1,mp ja=j+(mpos-1)*mp faver(ja,k)=0. do i=1,iulim relt =(relx(i,j)**2+rely(i,j)**2) & /(relx(i,j)+rely(i,j)+1.e-13) alph =(tau(k,i,j)**2+relt**2) & /(tau(k,i,j)+relt+1.e-13) alph=alph*iflg+float(1-iflg) faver(ja,k)=faver(ja,k)+alph*f(i,j,k) enddo faver(ja,k)=faver(ja,k)/iulim enddo enddo CALL MPI_Reduce(faver/nprocx,fav,mpl,DC_TYPE,MPI_SUM, $ 0,MPI_COMM_EULAG ,ierror) #else do k=1,l do j=1,mp fav(j,k)=0. do i=1,iulim relt =(relx(i,j)**2+rely(i,j)**2) & /(relx(i,j)+rely(i,j)+1.e-13) alph =(tau(k,i,j)**2+relt**2) & /(tau(k,i,j)+relt+1.e-13) alph=alph*iflg+float(1-iflg) fav(j,k)=fav(j,k)+alph*f(i,j,k) end do fav(j,k)=fav(j,k)/iulim end do end do #endif return end ! subroutine zonav(f,fav,tau,iflg) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(mp,l),raver(mp,l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . fav(mp,l),rav(mp,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw #if (TIMEPLT == 1) call ttbeg(28) #endif #if(PARALLEL > 0) mpl=mp*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif do k=1,l do j=1,mp faver(j,k)=0. raver(j,k)=0. c ja=j+(mpos-1)*mp do i=1,iulim c ia=i+(npos-1)*np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) faver(j,k)=faver(j,k)+alph*rho(i,j,k)*f(i,j,k) raver(j,k)=raver(j,k)+alph*rho(i,j,k) enddo enddo enddo c goto 99 CALL MPI_ALLReduce(faver,fav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) CALL MPI_ALLReduce(raver,rav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) c 99 continue do j=1,mp do k=1,l fav(j,k)=fav(j,k)/amax1(rav(j,k), 1.e-15) enddo enddo #else do 1 k=1,l do 1 j=1,mp fav(j,k)=0. rav(j,k)=0. do 10 i=1,np-ibcx c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) fav(j,k)=fav(j,k)+alph*rho(i,j,k)*f(i,j,k) 10 rav(j,k)=rav(j,k)+alph*rho(i,j,k) 1 fav(j,k)=fav(j,k)/amax1(rav(j,k),1.e-15) #endif #if (TIMEPLT == 1) call ttend(28) #endif return end subroutine spherav(f,fav,tau,iflg) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(l),raver(l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . fav(l),rav(l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw #if (TIMEPLT == 1) call ttbeg(28) #endif #if(PARALLEL > 0) mpl=mp*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif do k=1,l faver(k)=0. raver(k)=0. do j=1,mp c ja=j+(mpos-1)*mp do i=1,iulim c ia=i+(npos-1)*np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) faver(k)=faver(k)+alph*rho(i,j,k)*f(i,j,k) raver(k)=raver(k)+alph*rho(i,j,k) enddo enddo enddo c goto 99 CALL MPI_ALLReduce(faver,fav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) CALL MPI_ALLReduce(raver,rav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) c 99 continue do k=1,l fav(k)=fav(k)/amax1(rav(k), 1.e-15) enddo #else do 1 k=1,l fav(k)=0. rav(k)=0. do 1 j=1,mp do 10 i=1,np-ibcx c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) fav(k)=fav(k)+alph*rho(i,j,k)*f(i,j,k) 10 rav(k)=rav(k)+alph*rho(i,j,k) 1 fav(k)=fav(k)/amax1(rav(k),1.e-15) #endif #if (TIMEPLT == 1) call ttend(28) #endif return end #if (ANALIZE == 0) subroutine advec(xf,xd1,xd2,xd3,iflg,ifirst) include 'param.nml' include 'msg.inc' dimension xd1(1-ih:np+ih, 1-ih:mp+ih, l), . xd2(1-ih:np+ih, 1-ih:mp+ih, l), . xd3(1-ih:np+ih, 1-ih:mp+ih, l), . xf(1-ih:np+ih, 1-ih:mp+ih, l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) c return #if (TIMEPLT == 1) call ttbeg(30) #endif #if (SEMILAG == 1) #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ifirst) #endif #if (J3DIM == 0) call inter2(xf,xd1,xd3,ifirst) #endif #endif #if (SEMILAG == 0) #if (J3DIM == 1) c if(iflg.eq.1) then c if(iflg.eq.1.or.(iflg.ge.31.and.iflg.le.33)) then if(iflg.ge.2.and.iflg.le.4) then call mpdata3(xd1,xd2,xd3,xf,d,iflg) c call mpdatm3(xd1,xd2,xd3,xf,d,iflg) else c call mpdatm3(xd1,xd2,xd3,xf,d,iflg) call mpdata3(xd1,xd2,xd3,xf,d,iflg) endif #endif #if (J3DIM == 0) if(iflg.ge.2.and.iflg.le.5) then call mpdatm2(xd1,xd3,xf,d,iflg) !default else call mpdata2(xd1,xd3,xf,d,iflg) !default endif #endif #endif #if (TIMEPLT == 1) call ttend(30) #endif return end #if (SEMILAG == 0) #if (J3DIM == 0) subroutine mpdata2(u1,u2,x,h,iflg) include 'param.nml' include 'msg.inc' dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iord0=2,isor=1,nonos=1,idiv=0) parameter(n1=np+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+l)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(l,2),scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) #if (TIMEPLT == 1) call ttbeg(31) #endif call updatelr(x,np,mp,l,np,mp,iupx) iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx illim1 = 1 illim2 = 1 + leftedge illim3 = 1 + 2*leftedge iulim1 = np + rightedge iulim2 = np - rightedge illimx = 1 + (1-ibcx)*leftedge illimx2 = 1 + (2-ibcx)*leftedge iulimx = np + (ibcx-1)*rightedge #else ibox=0 illim1 = 1 illim2 = 1 illim3 = 1 iulim1 = np iulim2 = np illimx = 1 illimx2 = 1 iulimx = np #endif do j=1,n2m do i=illim2,np v1(i,1,j) = u1(i,1,j) end do end do #if (POLES == 0) if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j) = ubc(1,j,1) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j) = ubc(1,j,2) end do end if #endif do i=1,np do j=2,n2m v2(i,1,j) = u2(i,1,j) end do #if (POLES == 0) v2(i,1, 1) = wbc(i,1,1) v2(i,1,n2) = wbc(i,1,2) #endif enddo if(nonos.eq.1) then do j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+(1-ibcx)*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+(1-ibcx)*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) end do end do endif do 3 k=1,iord if ((k.eq.1).and.(ibcx.eq.0)) call mp2bc(x,iflg,bcx,n1m,n2m) do 331 j=1,n2m do 331 i=illim2,np 331 f1(i,1,j)=donor(x(i-1,1,j),x(i,1,j),v1(i,1,j)) #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=f1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=donor(bcx(j,1),x(1,1,j),v1(1,1,j)) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=donor(x(np,1,j),bcx(j,2),v1(np+1,1,j)) enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif do 332 j=2,n2m do 332 i=1,np 332 f2(i,1,j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) if (iprec.eq.1) then do i=1,np f2(i,1, 1)=donor(x(i,1, 1),x(i,1, 1),v2(i,1, 1)) f2(i,1,n2)=donor(x(i,1,n2m),x(i,1,n2m),v2(i,1,n2)) end do else do i=1,np f2(i,1, 1)=-f2(i,1, 2 )*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2 )*ibcz end do end if do 333 j=1,n2m do 333 i=1,np 333 x(i,1,j)=x(i,1,j)-(f1(i+1,1,j)-f1(i,1,j)+f2(i,1,j+1)- . f2(i,1,j))/h(i,1,j) if(k.eq.iord) go to 6 do 49 j=1,n2m do 49 i=1,iulim1 f1(i,1,j)=v1(i,1,j) 49 v1(i,1,j)=0. do 50 j=1,n2 do 50 i=1,np f2(i,1,j)=v2(i,1,j) 50 v2(i,1,j)=0. if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if call updatelr(f2,np,mp,l+1,np,mp,1) call updatelr(x,np,mp,l,np,mp,iupx) do 51 j=2,n2-2 do 51 i=illim2,np 51 v1(i,1,j)=vdyf(x(i-1,1,j),x(i,1,j),f1(i,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) * +vcorr(f1(i,1,j), f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ . f2(i,1,j), * abs(x(i-1,1,j+1))+abs(x(i,1,j+1))- . abs(x(i-1,1,j-1))-abs(x(i,1,j-1)), . abs(x(i-1,1,j+1))+abs(x(i,1,j+1))+ . abs(x(i-1,1,j-1))+abs(x(i,1,j-1))+ep, * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim2,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), . .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ . f2(i,1,1), * abs(x(i-1,1,2 ))+abs(x(i,1,2 ))- . abs(x(i-1,1,n2mm))-abs(x(i,1,n2mm)), . abs(x(i-1,1,2 ))+abs(x(i,1,2 ))+ . abs(x(i-1,1,n2mm))+abs(x(i,1,n2mm))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo else !ibcz test do i=illim2,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), . .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=vdyf(x(i-1,1,n2m),x(i,1,n2m),f1(i,1,n2m), . .5*(h(i-1,1,n2m)+h(i,1,n2m))) enddo endif if(idiv.eq.1) then do 511 j=2-ibcz,n2-2+ibcz do 511 i=illim2,np 511 v1(i,1,j)=v1(i,1,j) * -vdiv1(f1(i-1,1,j),f1(i,1,j),f1(i+1,1,j),.5*(h(i-1,1,j)+ . h(i,1,j))) * -vdiv2(f1(i,1,j),f2(i-1,1,j+1),f2(i,1,j+1),f2(i-1,1,j), . f2(i,1,j),.5*(h(i-1,1,j)+h(i,1,j))) endif do 52 j=2,n2m do 52 i=illim2,iulim2 52 v2(i,1,j)=vdyf(x(i,1,j-1),x(i,1,j),f2(i,1,j),.5*(h(i,1,j-1)+ . h(i,1,j))) * +vcorr(f2(i,1,j), f1(i,1,j-1)+f1(i,1,j)+f1(i+1,1,j)+ . f1(i+1,1,j-1), * abs(x(i+1,1,j-1))+abs(x(i+1,1,j))- . abs(x(i-1,1,j-1))-abs(x(i-1,1,j)), . abs(x(i+1,1,j-1))+abs(x(i+1,1,j))+ . abs(x(i-1,1,j-1))+abs(x(i-1,1,j))+ep, * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then i0=-1 if (leftedge.eq.1) then do j=2,n2m v2(1,1,j)=vdyf(x(1,1,j-1),x(1,1,j),f2(1,1,j), . .5*(h(1,1,j-1)+h(1,1,j))) * +vcorr(f2(1,1,j), f1(1,1,j-1)+f1(1,1,j)+f1(2,1,j)+f1(2,1,j-1), * abs(x(2,1,j-1))+abs(x(2,1,j))-abs(x(i0,1,j-1))-abs(x(i0,1,j)), * abs(x(2,1,j-1))+abs(x(2,1,j))+abs(x(i0,1,j-1))+abs(x(i0,1,j))+ * ep,.5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif enddo end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) end do endif #endif end if #endif if(idiv.eq.1) then do 521 j=2,n2m do 521 i=illimx,iulimx 521 v2(i,1,j)=v2(i,1,j) * -vdiv1(f2(i,1,j-1),f2(i,1,j),f2(i,1,j+1),.5* . (h(i,1,j-1)+h(i,1,j))) * -vdiv2(f2(i,1,j),f1(i+1,1,j),f1(i+1,1,j-1),f1(i,1,j-1), * f1(i,1,j),.5*(h(i,1,j-1)+h(i,1,j))) endif if(isor.eq.3) then do 61 j=2-ibcz,n2-2+ibcz do 61 i=illim3,iulim2 61 v1(i,1,j)=v1(i,1,j) +vcor31(f1(i,1,j), 1 x(i-2,1,j),x(i-1,1,j),x(i,1,j),x(i+1,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(2,1,j)=v1(2,1,j) +vcor31(f1(2,1,j), 1 x(-1,1,j),x(1,1,j),x(2,1,j),x(3,1,j), . .5*(h(1,1,j)+h(2,1,j))) enddo end if if (rightedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(np,1,j)=v1(np,1,j) +vcor31(f1(np,1,j), . x(np-2,1,j),x(np-1,1,j),x(np,1,j),x(np+2,1,j), . .5*(h(np-1,1,j)+h(np,1,j))) enddo end if endif #endif do 62 j=2,n2-2 do 62 i=illimx2,iulimx 62 v1(i,1,j)=v1(i,1,j) 1 +vcor32(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ . f2(i,1,j), * abs(x(i,1,j+1 ))-abs(x(i,1,j-1 ))- . abs(x(i-1,1,j+1))+abs(x(i-1,1,j-1)), * abs(x(i,1,j+1 ))+abs(x(i,1,j-1 ))+ . abs(x(i-1,1,j+1))+abs(x(i-1,1,j-1))+ep, * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illimx2,iulimx v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ . f2(i,1,1), * abs(x(i,1,2 ))-abs(x(i,1,n2mm ))- . abs(x(i-1,1,2))+abs(x(i-1,1,n2mm)), * abs(x(i,1,2 ))+abs(x(i,1,n2mm ))+ . abs(x(i-1,1,2))+abs(x(i-1,1,n2mm))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo endif do 63 j=3,n2-2 do 63 i=illimx,iulimx !!! 1+(1-ibcx)*leftedge, np+(ibcx-1)*rightedge 63 v2(i,1,j)=v2(i,1,j) +vcor31(f2(i,1,j), 1 x(i,1,j-2),x(i,1,j-1),x(i,1,j),x(i,1,j+1),.5* . (h(i,1,j-1)+h(i,1,j))) if(ibcz.eq.1) then do i=illimx,iulimx v2(i,1,2)=v2(i,1,2) +vcor31(f2(i,1,2), 1 x(i,1,n2mm),x(i,1,1),x(i,1,2),x(i,1,3),.5* . (h(i,1,1)+h(i,1,2))) v2(i,1,n2m)=v2(i,1,n2m) +vcor31(f2(i,1,n2m), 1 x(i,1,n2m-2),x(i,1,n2mm),x(i,1,n2m),x(i,1,2),.5* . (h(i,1,n2mm)+h(i,1,n2m))) enddo endif do 64 j=3-ibcz,n2-2+ibcz do 64 i=illim2,iulim2 !!! 1+1*leftedge, np-1*rightedge 64 v2(i,1,j)=v2(i,1,j) 1 +vcor32(f2(i,1,j),f1(i,1,j-1)+f1(i+1,1,j-1)+f1(i+1,1,j)+ . f1(i,1,j), * abs(x(i+1,1,j ))-abs(x(i-1,1,j ))- . abs(x(i+1,1,j-1))+abs(x(i-1,1,j-1)), * abs(x(i+1,1,j ))+abs(x(i-1,1,j ))+ . abs(x(i+1,1,j-1))+abs(x(i-1,1,j-1))+ep, * .5*(h(i ,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(1,1,j)=v2(1,1,j) 1 +vcor32(f2(1,1,j),f1(1,1,j-1)+f1(2,1,j-1)+ . f1(2,1,j)+f1(1,1,j), * abs(x(2,1,j ))-abs(x(-1,1,j ))- . abs(x(2,1,j-1))+abs(x(-1,1,j-1)), * abs(x(2,1,j ))+abs(x(-1,1,j ))+ . abs(x(2,1,j-1))+abs(x(-1,1,j-1))+ep, * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(np,1,j)=v2(np+1,1,j) end do end if #endif endif !ibcx=1 #endif endif !isor=3 #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz end do end if if(nonos.eq.1) then c non-oscillatory option do 401 j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do 401 i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+ibox*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+ibox*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mx(i,1,j)) 401 mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mn(i,1,j)) do 402 j=1,n2m do 402 i=illim2,np 402 f1(i,1,j)=donor(x(i-1,1,j),x(i,1,j),v1(i,1,j)) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1 ,j)=f1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1 ,j)=0. enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=0. enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif if (iprec.eq.1) then do 4031 i=1,np do j=2,n2m f2(i,1, j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) enddo f2(i,1, 1)=0. f2(i,1,n2)=0. 4031 continue else do 4032 i=1,np do j=2,n2m f2(i,1,j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) enddo f2(i,1, 1)=-f2(i,1, 2)*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2)*ibcz 4032 continue endif do 404 j=1,n2m do 404 i=1,np cp(i,1,j)=(mx(i,1,j)-x(i,1,j))*h(i,1,j)/ 1(pn(f1(i+1,1,j))+pp(f1(i,1,j))+pn(f2(i,1,j+1))+pp(f2(i,1,j))+ep) cn(i,1,j)=(x(i,1,j)-mn(i,1,j))*h(i,1,j)/ 1(pp(f1(i+1,1,j))+pn(f1(i,1,j))+pp(f2(i,1,j+1))+pn(f2(i,1,j))+ep) 404 continue call updatelr(cp,np,mp,l,np,mp,1) call updatelr(cn,np,mp,l,np,mp,1) do 405 j=1,n2m do 405 i=illim2,np v1(i,1,j)=pp(v1(i,1,j))* 1 ( amin1(1.,cp(i,1,j),cn(i-1,1,j))*pp(sign(1., x(i-1,1,j))) 1 +amin1(1.,cp(i-1,1,j),cn(i,1,j))*pp(sign(1.,-x(i-1,1,j))) ) 2 -pn(v1(i,1,j))* 2 ( amin1(1.,cp(i-1,1,j),cn(i,1,j))*pp(sign(1., x(i,1 ,j ))) 2 +amin1(1.,cp(i,1,j),cn(i-1,1,j))*pp(sign(1.,-x(i,1 ,j ))) ) 405 continue do 406 j=2,n2m do 406 i=1,np v2(i,1,j)=pp(v2(i,1,j))* 1 ( amin1(1.,cp(i,1,j),cn(i,1,j-1))*pp(sign(1., x(i,1,j-1))) 1 +amin1(1.,cp(i,1,j-1),cn(i,1,j))*pp(sign(1.,-x(i,1,j-1))) ) 1 -pn(v2(i,1,j))* 2 ( amin1(1.,cp(i,1,j-1),cn(i,1,j))*pp(sign(1., x(i,1 ,j ))) 2 +amin1(1.,cp(i,1,j),cn(i,1,j-1))*pp(sign(1.,-x(i,1 ,j ))) ) 406 continue #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1(1,1,j)=v1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m v1(1,1,j)=0. enddo end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=0. enddo end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif endif 3 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(31) #endif return end subroutine mpdatm2(u1,u2,x,h,iflg) include 'param.nml' include 'msg.inc' dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(isor=1,nonos=1,idiv=0) parameter(n1=np+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+l)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(l,2),scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r vcor31(a,x0,x1,x2,x3,r)= . -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3.*rat4(x1,x2,x0,x3) vcor32(a,b,y0,y1,y2,y3,r)= . 0.25*b/r*(abs(a)-2.*a**2/r)*rat4(y0,y1,y2,y3) c iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib #if (TIMEPLT == 1) call ttbeg(32) #endif call update(x,np,mp,l,np,mp,iupx) itmx=2-liner iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx ibc=ibcx illim = 1 + leftedge iulim = np #else ibox=0 ibc=1 illim = 1 iulim = np #endif do j=1,n2m do i=illim,iulim v1(i,1,j) = u1(i,1,j) end do end do #if (POLES == 0) if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j) = ubc(1,j,1) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j) = ubc(1,j,2) end do end if #endif do i=1,np do j=2,n2m v2(i,1,j) = u2(i,1,j) end do v2(i,1, 1) = wbc(i,1,1) v2(i,1,n2) = wbc(i,1,2) enddo if(nonos.eq.1) then do j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibc*(i-1+(n1-i)/n1m*(n1-2))+ibo*max0(i-1,1 ) cvec ip=ibc*(i+1 -i /n1m*(n1-2))+ibo*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) end do end do endif c1=1. c2=0. do 3 k=1,itmx #if (POLES == 0) if((k.eq.1).and.(ibcx.eq.0)) call mp2bc(x,iflg,bcx,n1m,n2m) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 j=1,n2m do 331 i=illim,iulim 331 f1(i,1,j)=donor(c1*x(i-1,1,j)+c2,c1*x(i,1,j)+c2,v1(i,1,j)) cex . -c1*ampd*.5*(h(i,1,j)+h(i-1,1,j))*(x(i,1,j)-x(i-1,1,j)) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=f1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=donor(c1*bcx(j,1)+c2,c1*x(1,1,j)+c2,v1(1,1,j)) end do end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=donor(c1*x(np,1,j)+c2,c1*bcx(j,2)+c2, . v1(np+1,1,j)) enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif do 332 j=2,n2m do 332 i=1,np 332 f2(i,1,j)=donor(c1*x(i,1,j-1)+c2,c1*x(i,1,j)+c2,v2(i,1,j)) cex . -c1*ampd*.5*(h(i,1,j)+h(i,1,j-1))*(x(i,1,j)-x(i,1,j-1)) if (iprec.eq.1) then do i=1,np f2(i,1, 1)=donor(c1*x(i,1, 1)+c2,c1*x(i,1, 1)+c2,v2(i,1, 1)) f2(i,1,n2)=donor(c1*x(i,1,n2m)+c2,c1*x(i,1,n2m)+c2,v2(i,1,n2)) end do else do i=1,np f2(i,1, 1)=-f2(i,1, 2 )*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2 )*ibcz end do end if do 333 j=1,n2m do 333 i=1,np 333 x(i,1,j)=x(i,1,j)-(f1(i+1,1,j)-f1(i,1,j)+f2(i,1,j+1)-f2(i,1,j))/ . h(i,1,j) if(k.eq.itmx) go to 6 c1=0. c2=1. #if (POLES == 0) illim = 1 iulim = np + 1*rightedge #else illim = 1 iulim = np #endif do 49 j=1,n2m do 49 i=illim,iulim f1(i,1,j)=v1(i,1,j) 49 v1(i,1,j)=0. do 50 j=1,n2 do 50 i=1,np f2(i,1,j)=v2(i,1,j) 50 v2(i,1,j)=0. if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if call updatelr(f2,np,mp,l+1,np,mp,1) call updatelr(x,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 51 j=2,n2-2 do 51 i=illim,iulim 51 v1(i,1,j)=vdyf(x(i-1,1,j),x(i,1,j),f1(i,1,j),.5* . (h(i-1,1,j)+h(i,1,j))) * +vcorr(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+f2(i,1,j), * x(i-1,1,j-1),x(i,1,j-1),x(i-1,1,j+1),x(i,1,j+1), * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1),.5* . (h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+f2(i,1,1), . x(i-1,1,n2mm),x(i,1,n2mm),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo else !ibcz test do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1),.5* . (h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=vdyf(x(i-1,1,n2m),x(i,1,n2m),f1(i,1,n2m),.5* . (h(i-1,1,n2m)+h(i,1,n2m))) enddo endif if(idiv.eq.1) then #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 511 j=2-ibcz,n2-2+ibcz do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,1,j),f1(i,1,j),f1(i+1,1,j),.5* . (h(i-1,1,j)+h(i,1,j))) * -vdiv2(f1(i,1,j),f2(i-1,1,j+1),f2(i,1,j+1),f2(i-1,1,j), * f2(i,1,j), .5*(h(i-1,1,j)+h(i,1,j))) 511 v1(i,1,j)=v1(i,1,j)+(pp(v1d)*x(i-1,1,j)-pn(v1d)*x(i,1,j)) endif #if (POLES == 0) illim = 1 + leftedge iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do 52 j=2,n2m do 52 i=illim,iulim 52 v2(i,1,j)=vdyf(x(i,1,j-1),x(i,1,j),f2(i,1,j),.5* . (h(i,1,j-1)+h(i,1,j))) * +vcorr(f2(i,1,j), f1(i,1,j-1)+f1(i,1,j)+f1(i+1,1,j)+ . f1(i+1,1,j-1), * x(i-1,1,j-1),x(i-1,1,j),x(i+1,1,j-1),x(i+1,1,j), * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2,n2m v2(1,1,j)=vdyf(x(1,1,j-1),x(1,1,j),f2(1,1,j),.5* . (h(1,1,j-1)+h(1,1,j))) * +vcorr(f2(1,1,j), f1(1,1,j-1)+f1(1,1,j)+f1(2,1,j)+ . f1(2,1,j-1),x(-1,1,j-1),x(-1,1,j), . x(2,1,j-1),x(2,1,j), * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) enddo end if #endif endif #endif if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 521 j=2,n2m do 521 i=illim,iulim v2d=-vdiv1(f2(i,1,j-1),f2(i,1,j),f2(i,1,j+1), . .5*(h(i,1,j-1)+h(i,1,j))) * -vdiv2(f2(i,1,j),f1(i+1,1,j-1),f1(i+1,1,j),f1(i,1,j-1), . f1(i,1,j),.5*(h(i,1,j-1)+h(i,1,j))) 521 v2(i,1,j)=v2(i,1,j)+(pp(v2d)*x(i,1,j-1)-pn(v2d)*x(i,1,j)) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do 61 j=2-ibcz,n2-2+ibcz do 61 i=illim,iulim 61 v1(i,1,j)=v1(i,1,j) +vcor31(f1(i,1,j), 1 x(i-2,1,j),x(i-1,1,j),x(i,1,j),x(i+1,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) c #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(2,1,j)=v1(2,1,j) +vcor31(f1(2,1,j), 1 x(-1,1,j),x(1,1,j),x(2,1,j),x(3,1,j), . .5*(h(1,1,j)+h(2,1,j))) end do end if if (rightedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(np,1,j)=v1(np,1,j) +vcor31(f1(np,1,j),x(np-2,1,j), . x(np-1,1,j), 1 x(np,1,j),x(np+2,1,j),.5*(h(np-1,1,j)+h(np,1,j))) enddo end if endif #endif #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 62 j=2,n2-2 do 62 i=illim,iulim 62 v1(i,1,j)=v1(i,1,j) 1 +vcor32(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ * f2(i,1,j), * x(i,1,j-1),x(i-1,1,j+1),x(i-1,1,j-1),x(i,1,j+1), * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ * f2(i,1,1), * x(i,1,n2mm),x(i-1,1,2),x(i-1,1,n2mm),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo endif #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 63 j=3,n2-2 do 63 i=illim,iulim 63 v2(i,1,j)=v2(i,1,j) +vcor31(f2(i,1,j), 1 x(i,1,j-2),x(i,1,j-1),x(i,1,j),x(i,1,j+1), . .5*(h(i,1,j-1)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v2(i,1,2)=v2(i,1,2) +vcor31(f2(i,1,2), 1 x(i,1,n2mm),x(i,1,1),x(i,1,2),x(i,1,3),.5* . (h(i,1,1)+h(i,1,2))) v2(i,1,n2m)=v2(i,1,n2m) +vcor31(f2(i,1,n2m), 1 x(i,1,n2m-2),x(i,1,n2mm),x(i,1,n2m),x(i,1,2),.5* . (h(i,1,n2mm)+h(i,1,n2m))) enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 64 j=3-ibcz,n2-2+ibcz do 64 i=illim,iulim 64 v2(i,1,j)=v2(i,1,j) 1 +vcor32(f2(i,1,j),f1(i,1,j-1)+f1(i+1,1,j-1)+f1(i+1,1,j)+ . f1(i,1,j), * x(i+1,1,j-1),x(i-1,1,j),x(i-1,1,j-1),x(i+1,1,j), * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(1,1,j)=v2(1,1,j) 1 +vcor32(f2(1,1,j),f1(1,1,j-1)+f1(2,1,j-1)+ . f1(2,1,j)+f1(1,1,j), * x(2,1,j-1),x(-1,1,j),x(-1,1,j-1),x(2,1,j), * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(np,1,j)=v2(np+1,1,j) end do end if #endif endif #endif endif #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif if(nonos.eq.1) then c non-osscilatory option do 401 j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do 401 i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+ibox*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+ibox*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mx(i,1,j)) 401 mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mn(i,1,j)) #if (POLES == 0) iulim = np + 1*rightedge #else iulim = np #endif do 402 j=1,n2m do 402 i=1,iulim 402 f1(i,1,j)=donor(c2,c2,v1(i,1,j)) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if do 403 j=1,n2 do 403 i=1,np 403 f2(i,1,j)=donor(c2,c2,v2(i,1,j)) do 404 j=1,n2m do 404 i=1,np cp(i,1,j)=(mx(i,1,j)-x(i,1,j))*h(i,1,j)/ 1(pn(f1(i+1,1,j))+pp(f1(i,1,j))+pn(f2(i,1,j+1))+pp(f2(i,1,j))+ep) cn(i,1,j)=(x(i,1,j)-mn(i,1,j))*h(i,1,j)/ 1(pp(f1(i+1,1,j))+pn(f1(i,1,j))+pp(f2(i,1,j+1))+pn(f2(i,1,j))+ep) 404 continue call updatelr(cp,np,mp,l,np,mp,1) call updatelr(cn,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do j=1,n2m do i=illim,np v1(i,1,j)=pp(v1(i,1,j))*amin1(1.,cp(i,1,j ),cn(i-1,1,j)) * -pn(v1(i,1,j))*amin1(1.,cp(i-1,1,j),cn(i ,1,j)) end do end do do j=2,n2m do i=1,np v2(i,1,j)=pp(v2(i,1,j))*amin1(1.,cp(i,1,j ),cn(i,1,j-1)) * -pn(v2(i,1,j))*amin1(1.,cp(i,1,j-1),cn(i,1,j )) end do end do #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif endif 3 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(32) #endif return end subroutine mp2bc(x,iflg,bcx,n1,n2) include 'param.nml' include 'msg.inc' dimension x(1-ih:np+ih,1-ih:mp+ih,l),bcx(n2,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(33) #endif #if (POLES == 0) if(iflg.eq.1) then if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if else if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,1) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,1) enddo end if endif goto 999 endif if(iflg.eq.11) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,1) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,1) enddo end if goto 999 endif if(iflg.eq.2.or.iflg.eq.3) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,iflg) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,iflg) enddo end if goto 999 endif if(iflg.eq.51) then if (leftedge.eq.1) then do k=1,n2 g110w=1./((1-icylind)*gmm(1,1,k)*cosa(1,1)+icylind*1.) g220w=1./gmm(1,1,k) g11w=strxx(1,1)*g110w g21w=strxy(1,1)*g220w bcx(k,1)=g11w*prf(1,1,k,2)+g21w*prf(1,1,k,3)+strxd(1,1) end do end if if (rightedge.eq.1) then do k=1,n2 g110e=1./((1-icylind)*gmm(np,1,k)*cosa(np,1)+icylind*1.) g220e=1./gmm(np,1,k) g11e=strxx(np,1)*g110e g21e=strxy(np,1)*g220e bcx(k,2)=g11e*prf(np,1,k,2)+g21e*prf(np,1,k,3)+strxd(np,1) enddo end if goto 999 endif if(iflg.eq.52) then if (leftedge.eq.1) then do k=1,n2 g110w=1./((1-icylind)*gmm(1,1,k)*cosa(1,1)+icylind*1.) g220w=1./gmm(1,1,k) g12w=stryx(1,1)*g110w g22w=stryy(1,1)*g220w bcx(k,1)=g12w*prf(1,1,k,2)+g22w*prf(1,1,k,3)+stryd(1,1) end do end if if (rightedge.eq.1) then do k=1,n2 g110e=1./((1-icylind)*gmm(np,1,k)*cosa(np,1)+icylind*1.) g220e=1./gmm(np,1,k) g12e=stryx(np,1)*g110e g22e=stryy(np,1)*g220e bcx(k,2)=g12e*prf(np,1,k,2)+g22e*prf(np,1,k,3)+stryd(np,1) enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prfb( 1,1,k,iflg-30) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prfb(np,1,k,iflg-30) enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.6) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=qve( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=qve(np,1,k) enddo end if goto 999 endif #endif if(iflg.ge.7) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if goto 999 endif #endif 999 continue #if (TIMEPLT == 1) call ttend(33) #endif return end #else subroutine mpdata3(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(iord0=2,isor0=1,nonos=1,idiv=0) c parameter(iord0=2,isor=3,nonos=1,idiv=0) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/diffus/ sk(l),skr(l),sls common/ctherm/ rg,cpp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.*r**2)*y1/y2 c vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.**r**2)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(34) #endif if(iflg.ge.2.and.iflg.le.4) then isor=3 c isor=isor0 else isor=isor0 endif ! do j=1,mp ! do i=1,np ! if(iflg.eq.31.or.iflg.eq.32) then !mod bbc ! x(i,j, 1) = 0 ! x(i,j,l) = 0. ! endif ! if(iflg.eq.33) then ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! endif ! end do ! end do call update(x,np,mp,l,np,mp,iup) iord=iord0 if(isor.eq.3) iord=max0(iord,3) !mod mhd c if(isor.eq.3.and.iflg.lt.31) iord=max0(iord,3) c iord=3 if(liner.eq.1) iord=1 #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy #else ibox=0 iboy=0 #endif iboz=1-ibcz iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + j3*botedge julim = mp do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,n3m km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - 1 jp = j + 1 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif do 30 itr=1,iord #if (POLES == 0) if((itr.eq.1).and.((ibcx*ibcy).eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) #endif COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 k=1,n3m do 331 j=1,mp do 331 i=illim,iulim 331 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) c if(itr.eq.1.and.kampd(1).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=1,mp do i=illim,iulim c ampdx=ampd(1,j,1)*.5*(h(i,j,k)+h(i-1,j,k)) ampdx=sk(k)*.5*(h(i,j,k)+h(i-1,j,k))*dt*dxi**2 if (iflg.eq.1) then f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) & -skr(k)*.5*(h(i,j,k)+h(i-1,j,k))*(x(i,j,k)-x(i-1,j,k)) & *dt*dxi**2*trs(k)/thrs(k) else f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) endif enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do 332 k=1,n3m do 332 j=jllim,mp do 332 i=1,np 332 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) c if(itr.eq.1.and.kampd(2).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=jllim,mp do i=1,np c ampdy=.5*(ampd(1,j,2)+ampd(1,j-1,2)) c & *.5*(h(i,j,k)+h(i,j-1,k)) ampdy=sk(k)*.5*(h(i,j,k)+h(i,j-1,k))*dt*dyi**2 if (iflg.eq.1) then f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) & -skr(k)*.5*(h(i,j,k)+h(i,j-1,k))*(x(i,j,k)-x(i,j-1,k)) & *dt*dyi**2*trs(k)/thrs(k) else f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) endif enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) enddo enddo end if else if (botedge.eq.1) then do k=1,n3m do i=1,np if (iflg.eq.1) then f2(i,1,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) c f2(i,1,k)=-f2(i,2,k) else f2(i,1,k)=-f2(i,2,k) endif end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np if (iflg.eq.1) then f2(i,mp+1,k)=donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) c f2(i,mp+1,k)=-f2(i,mp,k) else f2(i,mp+1,k)=-f2(i,mp,k) endif enddo enddo end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=2,n3m do j=1,mp do i=1,np c ampdz=ampd(1,j,3)*.5*(h(i,j,k)+h(i,j,k-1)) if (iflg.eq.1) then ampdz=sk(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 & *(trs(k)+trs(k-1))/(thrs(k)+thrs(k-1)) f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) & -skr(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 & *(x(i,j,k)*trs(k)/thrs(k)-x(i,j,k-1)*trs(k-1)/thrs(k-1)) else ampdz=sk(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) endif enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(x(i,j, 1),x(i,j, 1),v3(i,j, 1)) f3(i,j,n3)=donor(x(i,j,n3m),x(i,j,n3m),v3(i,j,n3)) end do end do else do j=1,mp do i=1,np cdf f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz cdf f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz if (iflg.eq.0) then c if (itr.eq.iord.and.iflg.eq.1) then c if (itr.eq.0.and.iflg.eq.1) then !solar flux in dissip c-------- special for solar luminosity dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi hfbt=hf00 gactp=1./(gi(i,j)*gmus(n3m)) + *((1-icylind)*gmm(i,j,n3m)**2*cosa(i,j) + +icylind*gmm(i,j,n3m))*dnmi * dt*dzi hftp=hf00*(gacbt/gactp) C + *23. f3(i,j, 1)=2.*hfbt*gacbt-f3(i,j, 2) f3(i,j,n3)=2.*hftp*gactp-f3(i,j,n3m) c f3(i,j,n3)= f3(i,j,n3m) else c if (iflg.ge.31.and.iflg.le.33) then !mod bbc c f3(i,j, 1)= f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c f3(i,j,n3)= f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz c else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz c endif endif enddo enddo end if c if (iflg.eq.1) then do 334 k=1,n3m do 334 j=1,mp do 334 i=1,np 334 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) c . +(f3(i,j,k+1)-f3(i,j,k))*thrs(k)/trs(k) c . )/h(i,j,k) c else c do 339 k=1,n3m c do 339 j=1,mp c do 339 i=1,np c 339 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) c . +f2(i,j+1,k)-f2(i,j,k) c . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) c endif c !mod bbc ! if(iflg.eq.33) then ! do j=1,mp ! do i=1,np ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! enddo ! enddo ! endif if(itr.eq.iord) go to 6 #if (POLES == 0) iulim = np + rightedge #else iulim = np #endif do 48 k=1,n3m do 48 j=1,mp do 48 i=1,iulim f1(i,j,k)=v1(i,j,k) 48 v1(i,j,k)=0. julim = mp + topedge do 49 k=1,n3m do 49 j=1,julim do 49 i=1,np f2(i,j,k)=v2(i,j,k) 49 v2(i,j,k)=0. do 50 k=1,n3 do 50 j=1,mp do 50 i=1,np f3(i,j,k)=v3(i,j,k) 50 v3(i,j,k)=0. c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) #if (POLES == 0) jllim = 1 + botedge julim = mp - topedge illim = 1 + leftedge #else jllim = 1 julim = mp illim = 1 #endif do 51 k=2,n3-2 do 51 j=jllim,julim do 51 i=illim,np 51 v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * -abs(x(i-1,j-1,k))-abs(x(i,j-1,k)), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * +abs(x(i-1,j-1,k))+abs(x(i,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * -abs(x(i-1,j,k-1))-abs(x(i,j,k-1)), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * +abs(x(i-1,j,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * -abs(x(i-1,-1,k))-abs(x(i,-1,k)), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * +abs(x(i-1,-1,k))+abs(x(i,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * -abs(x(i-1,1,k-1))-abs(x(i,1,k-1)), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * +abs(x(i-1,1,k-1))+abs(x(i,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,mp,k)=v1(i,mp+1,k) end do end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * -abs(x(i-1,j,n3-2))-abs(x(i,j,n3-2)), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * +abs(x(i-1,j,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i-1,j, 1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * -abs(x(i-1,1,n3-2))-abs(x(i,1,n3-2)), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * +abs(x(i-1,1,n3-2))+abs(x(i,1,n3-2))+ep, * .5*(h(i-1,1, 1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i,j-1,n3m)), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i,j-1,n3m))+ep, * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * -abs(x(i-1,-1,n3m))-abs(x(i,-1,n3m)), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * +abs(x(i-1,-1,n3m))+abs(x(i,-1,n3m))+ep, * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i,1, 1 ) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge illim = 1 + leftedge #else illim = 1 jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,np 511 v1(i,j,k)=v1(i,j,k) * -vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 61 k=2-ibcz,n3-2+ibcz do 61 j=jllim,julim do 61 i=illim,iulim 61 v1(i,j,k)=v1(i,j,k) +vcor31(f1(i,j,k), 1 x(i-2,j,k),x(i-1,j,k),x(i,j,k),x(i+1,j,k), 1 .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if(leftedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(2,j,k)=v1(2,j,k) +vcor31(f1(2,j,k), 1 x(-1,j,k),x(1,j,k),x(2,j,k),x(3,j,k), 1 .5*(h(1,j,k)+h(2,j,k))) end do end do end if if(rightedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(np,j,k)=v1(np,j,k) +vcor31(f1(np,j,k), 1 x(np-2,j,k),x(np-1,j,k),x(np,j,k),x(np+2,j,k), 1 .5*(h(np-1,j,k)+h(np,j,k))) end do end do end if endif C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 62 k=2,n3-2 do 62 j=jllim,julim do 62 i=illim,iulim 62 v1(i,j,k)=v1(i,j,k) 1 +vcor32(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i-1,j+1,k)) * +abs(x(i-1,j-1,k)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i-1,j+1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) 1 +vcor32(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i-1,j,k+1)) * +abs(x(i-1,j,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i-1,j,k+1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) 1 +vcor32(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i-1,2,k)) * +abs(x(i-1,-1,k)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i-1,2,k))+abs(x(i-1,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) 1 +vcor32(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i,1,k+1))-abs(x(i,1,k-1))-abs(x(i-1,1,k+1)) * +abs(x(i-1,1,k-1)), abs(x(i,1,k+1))+abs(x(i,1,k-1)) * +abs(x(i-1,1,k+1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 63 k=2,n3-2 do 63 j=jllim,julim do 63 i=illim,iulim 63 v1(i,j,k)=v1(i,j,k) + vcor33(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1, k)+f2(i,j+1, k)+f2(i,j,k), * f3(i-1,j,k)+f3(i-1,j ,k+1)+f3(i,j ,k+1)+f3(i,j,k), * abs(x(i-1,j+1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))-abs(x(i ,j-1,k+1)) * -abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1)), * abs(x(i-1,j+1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))+abs(x(i ,j-1,k+1)) * +abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) + vcor33(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2, k)+f2(i,2, k)+f2(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,2,k+1))-abs(x(i-1,-1,k+1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))-abs(x(i ,-1,k+1)) * -abs(x(i ,2,k-1))+abs(x(i ,-1,k-1)), * abs(x(i-1,2,k+1))+abs(x(i-1,-1,k+1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))+abs(x(i ,-1,k+1)) * +abs(x(i ,2,k-1))+abs(x(i ,-1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) 1 +vcor32(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i ,j+1,1))-abs(x(i ,j-1,1)) * -abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1)), * abs(x(i ,j+1,1))+abs(x(i ,j-1,1)) * +abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) 1 +vcor32(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i ,j,2))-abs(x(i ,j,n3-2)) * -abs(x(i-1,j,2))+abs(x(i-1,j,n3-2)), * abs(x(i ,j,2))+abs(x(i ,j,n3-2)) * +abs(x(i-1,j,2))+abs(x(i-1,j,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i ,2,1))-abs(x(i ,-1,1)) * -abs(x(i-1,2,1))+abs(x(i-1,-1,1)), * abs(x(i ,2,1))+abs(x(i ,-1,1)) * +abs(x(i-1,2,1))+abs(x(i-1,-1,1))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) 1 +vcor32(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i ,1,2))-abs(x(i ,1,n3-2)) * -abs(x(i-1,1,2))+abs(x(i-1,1,n3-2)), * abs(x(i ,1,2))+abs(x(i ,1,n3-2)) * +abs(x(i-1,1,2))+abs(x(i-1,1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) + vcor33(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j+1, 2))-abs(x(i-1,j-1, 2)) * -abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))-abs(x(i ,j-1, 2)) * -abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2)), * abs(x(i-1,j+1, 2))+abs(x(i-1,j-1, 2)) * +abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))+abs(x(i ,j-1, 2)) * +abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) + vcor33(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,2, 2))-abs(x(i-1,-1, 2)) * -abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))-abs(x(i ,-1, 2)) * -abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2)), * abs(x(i-1,2, 2))+abs(x(i-1,-1, 2)) * +abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))+abs(x(i ,-1, 2)) * +abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) jllim = 1 + botedge julim = mp illim = 1 + leftedge iulim = np - rightedge #else jllim = 1 + botedge julim = mp illim = 1 iulim = np #endif do 52 k=2,n3-2 do 52 j=jllim,julim do 52 i=illim,iulim 52 v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * -abs(x(i-1,j-1,k))-abs(x(i-1,j,k)), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * +abs(x(i-1,j-1,k))+abs(x(i-1,j,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * -abs(x(i,j-1,k-1))-abs(x(i,j,k-1)), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * +abs(x(i,j-1,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * -abs(x(-1,j-1,k))-abs(x(-1,j,k)), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * +abs(x(-1,j-1,k))+abs(x(-1,j,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * -abs(x(1,j-1,k-1))-abs(x(1,j,k-1)), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * +abs(x(1,j-1,k-1))+abs(x(1,j,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+1,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * -abs(x(i,j-1,n3-2))-abs(x(i,j,n3-2)), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * +abs(x(i,j-1,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * -abs(x(1,j-1,n3-2))-abs(x(1,j,n3-2)), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * +abs(x(1,j-1,n3-2))+abs(x(1,j,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2( 1 ,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) * +vcorr(f2(i,j,n3m), c * f1(i,j-1,n3m)+f1(i,j,1)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), !mod Andii * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i-1,j,n3m)), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i-1,j,n3m))+ep, * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * -abs(x(-1,j-1,n3m))-abs(x(-1,j,n3m)), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * +abs(x(-1,j-1,n3m))+abs(x(-1,j,n3m))+ep, * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2(1,j, 1 ) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,mp v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 , 1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+1, 1 )= 0. v2(i,mp+1,n3m )= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge illim = 1 iulim = np #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim 521 v2(i,j,k)=v2(i,j,k) * -vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) jllim = 1 + 2*botedge julim = mp - j3*topedge illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge #else jllim = 1 + 2*j3*botedge julim = mp - j3*topedge illim = 1 iulim = np #endif do 71 k=2-ibcz,n3-2-ibcz do 71 j=jllim,julim do 71 i=illim,iulim 71 v2(i,j,k)=v2(i,j,k) +vcor31(f2(i,j,k), 1 x(i,j-2,k),x(i,j-1,k),x(i,j,k),x(i,j+1,k), 1 .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,-1,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) enddo enddo end if if (topedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2,k),x(i,mp-1,k),x(i,mp,k),x(i,mp+2,k), 1 .5*(h(i,mp-1,k)+h(i,mp,k))) enddo enddo end if endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,1-j3,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2*j3,k),x(i,mp-j3,k),x(i,mp,k),x(i,mp+j3,k), 1 .5*(h(i,mp-j3,k)+h(i,mp,k))) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) jllim = 1 + (2-ibcy)*botedge julim = mp - (1-ibcy)*topedge illim = 1 + leftedge iulim = np - rightedge #else jllim = 1+botedge julim = mp illim = 1 iulim = np #endif do 72 k=2,n3-2 do 72 j=jllim,julim do 72 i=illim,iulim 72 v2(i,j,k)=v2(i,j,k) 1 +vcor32(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j-1,k)) * +abs(x(i-1,j-1,k)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j-1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) 1 +vcor32(f2(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i,j-1,k+1)) * +abs(x(i,j-1,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i,j-1,k+1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) 1 +vcor32(f2(1,j,k), * f1(1,j-1,k)+f1(2,j-1,k)+f1(2,j,k)+f1(1,j,k), * abs(x( 2,j,k))-abs(x(-1,j,k))-abs(x(2,j-1,k)) * +abs(x(-1,j-1,k)), abs(x(2,j,k))+abs(x(-1,j,k)) * +abs(x(2,j-1,k))+abs(x(-1,j-1,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) 1 +vcor32(f2(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(1,j,k+1))-abs(x(1,j,k-1))-abs(x(1,j-1,k+1)) * +abs(x(1,j-1,k-1)), abs(x(1,j,k+1))+abs(x(1,j,k-1)) * +abs(x(1,j-1,k+1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do 73 k=2,n3-2 do 73 j=jllim,julim do 73 i=illim,iulim 73 v2(i,j,k)=v2(i,j,k) + vcor33(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i+1,j-1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))-abs(x(i-1, j ,k+1)) * -abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1)), * abs(x(i+1,j-1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))+abs(x(i-1, j ,k+1)) * +abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) + vcor33(f2(1,j,k), * f1(1,j-1,k)+f1( 2 ,j-1,k)+f1( 2 ,j,k)+f1(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(2,j-1,k+1))-abs(x(-1,j-1,k+1)) * -abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))-abs(x(-1, j ,k+1)) * -abs(x(2, j ,k-1))+abs(x(-1, j ,k-1)), * abs(x(2,j-1,k+1))+abs(x(-1,j-1,k+1)) * +abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))+abs(x(-1, j ,k+1)) * +abs(x(2, j ,k-1))+abs(x(-1, j ,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) 1 +vcor32(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * abs(x(i+1,j,1))-abs(x(i-1,j,1))-abs(x(i+1,j-1,1)) * +abs(x(i-1,j-1,1)), abs(x(i+1,j,1))+abs(x(i-1,j,1)) * +abs(x(i+1,j-1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) 1 +vcor32(f2(i,j,1), * f3(i,j-1,1)+f3(i,j-1, 2 )+f3(i,j, 2 )+f3(i,j,1), * abs(x(i,j,2))-abs(x(i,j,n3-2))-abs(x(i,j-1,2)) * +abs(x(i,j-1,n3-2)), abs(x(i,j,2))+abs(x(i,j,n3-2)) * +abs(x(i,j-1,2))+abs(x(i,j-1,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) 1 +vcor32(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * abs(x(2,j,1))-abs(x(-1,j,1))-abs(x(2,j-1,1)) * +abs(x(-1,j-1,1)), abs(x(2,j,1))+abs(x(-1,j,1)) * +abs(x(2,j-1,1))+abs(x(-1,j-1,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) 1 +vcor32(f2(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(1,j,2))-abs(x(1,j,n3-2))-abs(x(1,j-1,2)) * +abs(x(1,j-1,n3-2)), abs(x(1,j,2))+abs(x(1,j,n3-2)) * +abs(x(1,j-1,2))+abs(x(1,j-1,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) + vcor33(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * f3(i,j-1,1)+f3( i ,j-1,2)+f3( i ,j,2)+f3(i,j,1), * abs(x(i+1,j-1, 2 ))-abs(x(i-1,j-1, 2 )) * -abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))-abs(x(i-1, j , 2 )) * -abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2)), * abs(x(i+1,j-1, 2 ))+abs(x(i-1,j-1, 2 )) * +abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))+abs(x(i-1, j , 2 )) * +abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) + vcor33(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(2,j-1, 2 ))-abs(x(-1,j-1, 2 )) * -abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))-abs(x(-1, j , 2 )) * -abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2)), * abs(x(2,j-1, 2 ))+abs(x(-1,j-1, 2 )) * +abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))+abs(x(-1, j , 2 )) * +abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * -abs(x(i-1,j,k-1))-abs(x(i-1,j,k)), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * +abs(x(i-1,j,k-1))+abs(x(i-1,j,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * -abs(x(i,j-1,k-1))-abs(x(i,j-1,k)), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * +abs(x(i,j-1,k-1))+abs(x(i,j-1,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * -abs(x(-1,j,k-1))-abs(x(-1,j,k)), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * +abs(x(-1,j,k-1))+abs(x(-1,j,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * -abs(x(1,j-1,k-1))-abs(x(1,j-1,k)), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * +abs(x(1,j-1,k-1))+abs(x(1,j-1,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1-1,j,k)=v3(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) end do end do end if #endif endif !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * -abs(x(i-1,1,k-1))-abs(x(i-1,1,k)), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * +abs(x(i-1,1,k-1))+abs(x(i-1,1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * -abs(x(i,-1,k-1))-abs(x(i,-1,k)), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * +abs(x(i,-1,k-1))+abs(x(i,-1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) end do end do end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * -abs(x(-1,1,k-1))-abs(x(-1,1,k)), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * +abs(x(-1,1,k-1))+abs(x(-1,1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * -abs(x(1,-1,k-1))-abs(x(1,-1,k)), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * +abs(x(1,-1,k-1))+abs(x(1,-1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1 ,k)=v3(1,1,k) v3( 1 ,n2m,k)=v3(1,1,k) #endif enddo end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) end do end if if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) end do end if if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) end do end if #endif endif !ibcx=1 endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim 531 v3(i,j,k)=v3(i,j,k) * -vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 81 k=3,n3-2 do 81 j=jllim,julim do 81 i=illim,iulim 81 v3(i,j,k)=v3(i,j,k) +vcor31(f3(i,j,k), 1 x(i,j,k-2),x(i,j,k-1),x(i,j,k),x(i,j,k+1), 1 .5*(h(i,j,k-1)+h(i,j,k))) if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v3(i,j,2)=v3(i,j,2) +vcor31(f3(i,j,2), 1 x(i,j,n3-2),x(i,j,1),x(i,j,2),x(i,j,3), 1 .5*(h(i,j,1)+h(i,j,2))) v3(i,j,n3-1)=v3(i,j,n3-1) +vcor31(f3(i,j,n3-1), 1 x(i,j,n3-3),x(i,j,n3-2),x(i,j,n3-1),x(i,j,2), 1 .5*(h(i,j,n3-2)+h(i,j,n3-1))) enddo enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 82 k=3-ibcz,n3-2+ibcz do 82 j=jllim,julim do 82 i=illim,iulim 82 v3(i,j,k)=v3(i,j,k) 1 +vcor32(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i,j+1,k-1)) * +abs(x(i,j-1,k-1)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i,j+1,k-1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) 1 +vcor32(f3(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j,k-1)) * +abs(x(i-1,j,k-1)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j,k-1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) 1 +vcor32(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i,2,k-1)) * +abs(x(i,-1,k-1)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i,2,k-1))+abs(x(i,-1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) 1 +vcor32(f3(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,1,k))-abs(x(i-1,1,k))-abs(x(i+1,1,k-1)) * +abs(x(i-1,1,k-1)), abs(x(i+1,1,k))+abs(x(i-1,1,k)) * +abs(x(i+1,1,k-1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 83 k=3-ibcz,n3-2+ibcz do 83 j=jllim,julim do 83 i=illim,iulim 83 v3(i,j,k)=v3(i,j,k) + vcor33(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j+1,k-1))-abs(x(i+1,j-1,k-1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))-abs(x(i+1,j-1, k )) * -abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k )), * abs(x(i+1,j+1,k-1))+abs(x(i+1,j-1,k-1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))+abs(x(i+1,j-1, k )) * +abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k ))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) + vcor33(f3(i,1,k), * f2(i,1,k-1)+f2(i, 2 ,k-1)+f2(i, 2 ,k)+f2(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,2,k-1))-abs(x(i+1,-1,k-1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))-abs(x(i+1,-1, k )) * -abs(x(i-1,2, k ))+abs(x(i-1,-1, k )), * abs(x(i+1,2,k-1))+abs(x(i+1,-1,k-1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))+abs(x(i+1,-1, k )) * +abs(x(i-1,2, k ))+abs(x(i-1,-1, k ))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 if(ibcx.eq.1) then if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) 1 +vcor32(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1, k ))-abs(x(1,j-1, k )) * -abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1)), * abs(x(1,j+1, k ))+abs(x(1,j-1, k )) * +abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) 1 +vcor32(f3(1,j,k), * f1(1,j,k-1)+f1(2,j,k-1)+f1(2,j,k)+f1(1,j,k), * abs(x(2,j, k ))-abs(x(-1,j, k )) * -abs(x(2,j,k-1))+abs(x(-1,j,k-1)), * abs(x(2,j, k ))+abs(x(-1,j, k )) * +abs(x(2,j,k-1))+abs(x(-1,j,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) 1 +vcor32(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1,2,k))-abs(x(1,-1,k))-abs(x(1,2,k-1))+abs(x(1,-1,k-1)), * abs(x(1,2,k))+abs(x(1,-1,k))+abs(x(1,2,k-1))+abs(x(1,-1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) 1 +vcor32(f3(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x(2,1,k))-abs(x(-1,1,k))-abs(x(2,1,k-1))+abs(x(-1,1,k-1)), * abs(x(2,1,k))+abs(x(-1,1,k))+abs(x(2,1,k-1))+abs(x(-1,1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) + vcor33(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * f1(1,j,k-1)+f1(2, j ,k-1)+f1(2, j ,k)+f1(1,j,k), * abs(x( 2,j+1,k-1))-abs(x( 2,j-1,k-1)) * -abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))-abs(x( 2,j-1, k )) * -abs(x(-1,j+1, k ))+abs(x(-1,j-1, k )), * abs(x( 2,j+1,k-1))+abs(x( 2,j-1,k-1)) * +abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))+abs(x( 2,j-1, k )) * +abs(x(-1,j+1, k ))+abs(x(-1,j-1, k ))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) + vcor33(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x( 2,2,k-1))-abs(x( 2,-1,k-1)) * -abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))-abs(x( 2,-1, k )) * -abs(x(-1,2, k ))+abs(x(-1,-1, k )), * abs(x( 2,2,k-1))+abs(x( 2,-1,k-1)) * +abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))+abs(x( 2,-1, k )) * +abs(x(-1,2, k ))+abs(x(-1,-1, k ))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !isor=3 #if (POLES == 0) COLD if (ibcx.eq.1) then COLD do k=1,n3m COLD do j=1,n2m COLD v1(1 ,j,k)=v1(n1m,j,k) COLD v1(n1,j,k)=v1(2 ,j,k) COLD end do COLD end do COLD end if COLD if (ibcy.eq.1) then COLD do k=1,n3m COLD do i=1,n1m COLD v2(i, 1,k)=v2(i,n2m,k) COLD v2(i,n2,k)=v2(i,2 ,k) COLD end do COLD end do COLD end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if #endif COLD if (iflg.ne.8) then COLD do j=1,n2m COLD do i=1,n1m COLD v3(i,j, 1)=-v3(i,j, 2)*(1-ibcz)+v3(i,j,n3m)*ibcz COLD v3(i,j,n3)=-v3(i,j,n3m)*(1-ibcz)+v3(i,j, 2 )*ibcz COLD enddo COLD enddo COLD end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) C----------------/ #else /* POLES */ C----------------/ do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mx(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mn(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mx(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mn(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=illim,np 402 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1,j,k)=f1(-1,j,k)*ibcx end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k)*ibcx end do end do end if C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) #endif #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 403 k=1,n3m do 403 j=jllim,mp do 403 i=1,np 403 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k)*ibcy end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k)*ibcy end do end do end if C----------------/ #else /* POLES */ C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 4033 k=2,n3m do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=0. f3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2 )*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo endif do 404 k=1,n3m do 404 j=1,mp do 404 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 404 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)=pp(v1(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1., x(i-1,j,k))) 1 +amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1.,-x(i-1,j,k))) ) 2 -pn(v1(i,j,k))* 2 ( amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1., x(i ,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1.,-x(i ,j,k ))) ) enddo enddo enddo do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k)=pp(v2(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1., x(i,j-1,k))) 1 +amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1.,-x(i,j-1,k))) ) 1 -pn(v2(i,j,k))* 2 ( amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1., x(i,j ,k))) 2 +amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1.,-x(i,j ,k))) ) enddo enddo enddo do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)=pp(v3(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1., x(i,j,k-1))) 1 +amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1.,-x(i,j,k-1))) ) 1 -pn(v3(i,j,k))* 2 ( amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1., x(i,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1.,-x(i,j,k ))) ) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3 ,k) end do end do end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.1) then do j=1,mp do i=1,np v3(i,j, 1)=0. v3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2 )*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo endif 30 continue 6 continue c enforce cyclicity if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if (iencyc.eq.1) then if(ibcx.eq.1) then call updatelr(x,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp x(np,j,k)=x(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(x,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np x(i,mp,k)=x(i,mp+j3,k) enddo enddo endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) enddo enddo endif endif call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(34) #endif return end subroutine mpdata3_fil(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(iord0=2,isor=1,nonos=1,idiv=0) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 vdyf(x1,x2,a,r,ampl)=(0*2.*ampl*r+abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.**r**2)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(34) #endif call update(x,np,mp,l,np,mp,iup) iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy #else ibox=0 iboy=0 #endif iboz=1-ibcz iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + j3*botedge julim = mp do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,n3m km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - 1 jp = j + 1 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif do 30 itr=1,iord #if (POLES == 0) if((itr.eq.1).and.((ibcx*ibcy).eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) #endif COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 k=1,n3m do 331 j=1,mp do 331 i=illim,iulim 331 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) c if(itr.eq.1.and.kampd(1).ne.0) then if(itr.eq.iord) then do k=1,n3m do j=1,mp do i=illim,iulim ampdx=ampd(1,j,1)*.5*(h(i,j,k)+h(i-1,j,k)) f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do 332 k=1,n3m do 332 j=jllim,mp do 332 i=1,np 332 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) c if(itr.eq.1.and.kampd(2).ne.0) then if(itr.eq.iord) then do k=1,n3m do j=jllim,mp do i=1,np ampdy=.5*(ampd(1,j,2)+ampd(1,j-1,2)) & *.5*(h(i,j,k)+h(i,j-1,k)) f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) enddo enddo end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) enddo enddo end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then if(itr.eq.iord) then do k=2,n3m do j=1,mp do i=1,np ampdz=ampd(1,j,3)*.5*(h(i,j,k)+h(i,j,k-1)) f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(x(i,j, 1),x(i,j, 1),v3(i,j, 1)) f3(i,j,n3)=donor(x(i,j,n3m),x(i,j,n3m),v3(i,j,n3)) end do end do else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz enddo enddo end if do 334 k=1,n3m do 334 j=1,mp do 334 i=1,np 334 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) if(itr.eq.iord) go to 6 #if (POLES == 0) iulim = np + rightedge #else iulim = np #endif do 48 k=1,n3m do 48 j=1,mp do 48 i=1,iulim f1(i,j,k)=v1(i,j,k) 48 v1(i,j,k)=0. julim = mp + topedge do 49 k=1,n3m do 49 j=1,julim do 49 i=1,np f2(i,j,k)=v2(i,j,k) 49 v2(i,j,k)=0. do 50 k=1,n3 do 50 j=1,mp do 50 i=1,np f3(i,j,k)=v3(i,j,k) 50 v3(i,j,k)=0. c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) #if (POLES == 0) jllim = 1 + botedge julim = mp - topedge illim = 1 + leftedge #else jllim = 1 julim = mp illim = 1 #endif do 51 k=2,n3-2 do 51 j=jllim,julim do 51 i=illim,np 51 v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * -abs(x(i-1,j-1,k))-abs(x(i,j-1,k)), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * +abs(x(i-1,j-1,k))+abs(x(i,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * -abs(x(i-1,j,k-1))-abs(x(i,j,k-1)), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * +abs(x(i-1,j,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * -abs(x(i-1,-1,k))-abs(x(i,-1,k)), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * +abs(x(i-1,-1,k))+abs(x(i,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * -abs(x(i-1,1,k-1))-abs(x(i,1,k-1)), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * +abs(x(i-1,1,k-1))+abs(x(i,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,mp,k)=v1(i,mp+1,k) end do end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * -abs(x(i-1,j,n3-2))-abs(x(i,j,n3-2)), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * +abs(x(i-1,j,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i-1,j, 1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * -abs(x(i-1,1,n3-2))-abs(x(i,1,n3-2)), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * +abs(x(i-1,1,n3-2))+abs(x(i,1,n3-2))+ep, * .5*(h(i-1,1, 1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i,j-1,n3m)), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i,j-1,n3m))+ep, * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * -abs(x(i-1,-1,n3m))-abs(x(i,-1,n3m)), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * +abs(x(i-1,-1,n3m))+abs(x(i,-1,n3m))+ep, * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i,1, 1 ) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge illim = 1 + leftedge #else illim = 1 jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,np 511 v1(i,j,k)=v1(i,j,k) * -vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 61 k=2-ibcz,n3-2+ibcz do 61 j=jllim,julim do 61 i=illim,iulim 61 v1(i,j,k)=v1(i,j,k) +vcor31(f1(i,j,k), 1 x(i-2,j,k),x(i-1,j,k),x(i,j,k),x(i+1,j,k), 1 .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if(leftedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(2,j,k)=v1(2,j,k) +vcor31(f1(2,j,k), 1 x(-1,j,k),x(1,j,k),x(2,j,k),x(3,j,k), 1 .5*(h(1,j,k)+h(2,j,k))) end do end do end if if(rightedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(np,j,k)=v1(np,j,k) +vcor31(f1(np,j,k), 1 x(np-2,j,k),x(np-1,j,k),x(np,j,k),x(np+2,j,k), 1 .5*(h(np-1,j,k)+h(np,j,k))) end do end do end if endif C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp - 1*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 62 k=2,n3-2 do 62 j=jllim,julim do 62 i=illim,iulim 62 v1(i,j,k)=v1(i,j,k) 1 +vcor32(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i-1,j+1,k)) * +abs(x(i-1,j-1,k)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i-1,j+1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) 1 +vcor32(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i-1,j,k+1)) * +abs(x(i-1,j,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i-1,j,k+1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) 1 +vcor32(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i-1,2,k)) * +abs(x(i-1,-1,k)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i-1,2,k))+abs(x(i-1,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) 1 +vcor32(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i,1,k+1))-abs(x(i,1,k-1))-abs(x(i-1,1,k+1)) * +abs(x(i-1,1,k-1)), abs(x(i,1,k+1))+abs(x(i,1,k-1)) * +abs(x(i-1,1,k+1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 63 k=2,n3-2 do 63 j=jllim,julim do 63 i=illim,iulim 63 v1(i,j,k)=v1(i,j,k) + vcor33(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1, k)+f2(i,j+1, k)+f2(i,j,k), * f3(i-1,j,k)+f3(i-1,j ,k+1)+f3(i,j ,k+1)+f3(i,j,k), * abs(x(i-1,j+1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))-abs(x(i ,j-1,k+1)) * -abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1)), * abs(x(i-1,j+1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))+abs(x(i ,j-1,k+1)) * +abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) + vcor33(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2, k)+f2(i,2, k)+f2(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,2,k+1))-abs(x(i-1,-1,k+1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))-abs(x(i ,-1,k+1)) * -abs(x(i ,2,k-1))+abs(x(i ,-1,k-1)), * abs(x(i-1,2,k+1))+abs(x(i-1,-1,k+1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))+abs(x(i ,-1,k+1)) * +abs(x(i ,2,k-1))+abs(x(i ,-1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) 1 +vcor32(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i ,j+1,1))-abs(x(i ,j-1,1)) * -abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1)), * abs(x(i ,j+1,1))+abs(x(i ,j-1,1)) * +abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) 1 +vcor32(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i ,j,2))-abs(x(i ,j,n3-2)) * -abs(x(i-1,j,2))+abs(x(i-1,j,n3-2)), * abs(x(i ,j,2))+abs(x(i ,j,n3-2)) * +abs(x(i-1,j,2))+abs(x(i-1,j,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i ,2,1))-abs(x(i ,-1,1)) * -abs(x(i-1,2,1))+abs(x(i-1,-1,1)), * abs(x(i ,2,1))+abs(x(i ,-1,1)) * +abs(x(i-1,2,1))+abs(x(i-1,-1,1))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) 1 +vcor32(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i ,1,2))-abs(x(i ,1,n3-2)) * -abs(x(i-1,1,2))+abs(x(i-1,1,n3-2)), * abs(x(i ,1,2))+abs(x(i ,1,n3-2)) * +abs(x(i-1,1,2))+abs(x(i-1,1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) + vcor33(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j+1, 2))-abs(x(i-1,j-1, 2)) * -abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))-abs(x(i ,j-1, 2)) * -abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2)), * abs(x(i-1,j+1, 2))+abs(x(i-1,j-1, 2)) * +abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))+abs(x(i ,j-1, 2)) * +abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) + vcor33(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,2, 2))-abs(x(i-1,-1, 2)) * -abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))-abs(x(i ,-1, 2)) * -abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2)), * abs(x(i-1,2, 2))+abs(x(i-1,-1, 2)) * +abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))+abs(x(i ,-1, 2)) * +abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) jllim = 1 + botedge julim = mp illim = 1 + leftedge iulim = np - rightedge #else jllim = 1 + botedge julim = mp illim = 1 iulim = np #endif do 52 k=2,n3-2 do 52 j=jllim,julim do 52 i=illim,iulim 52 v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * -abs(x(i-1,j-1,k))-abs(x(i-1,j,k)), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * +abs(x(i-1,j-1,k))+abs(x(i-1,j,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * -abs(x(i,j-1,k-1))-abs(x(i,j,k-1)), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * +abs(x(i,j-1,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * -abs(x(-1,j-1,k))-abs(x(-1,j,k)), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * +abs(x(-1,j-1,k))+abs(x(-1,j,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * -abs(x(1,j-1,k-1))-abs(x(1,j,k-1)), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * +abs(x(1,j-1,k-1))+abs(x(1,j,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+1,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * -abs(x(i,j-1,n3-2))-abs(x(i,j,n3-2)), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * +abs(x(i,j-1,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * -abs(x(1,j-1,n3-2))-abs(x(1,j,n3-2)), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * +abs(x(1,j-1,n3-2))+abs(x(1,j,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2( 1 ,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,1)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i-1,j,n3m)), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i-1,j,n3m))+ep, * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * -abs(x(-1,j-1,n3m))-abs(x(-1,j,n3m)), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * +abs(x(-1,j-1,n3m))+abs(x(-1,j,n3m))+ep, * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2(1,j, 1 ) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,mp v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 , 1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+1, 1 )= 0. v2(i,mp+1,n3m )= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp #else jllim = 1 julim = mp + rightedge illim = 1 iulim = np #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim 521 v2(i,j,k)=v2(i,j,k) * -vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) jllim = 1 + 2*botedge julim = mp - 1*topedge illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge #else jllim = 1 + 2*botedge julim = mp - 1*topedge illim = 1 iulim = np #endif do 71 k=2-ibcz,n3-2-ibcz do 71 j=jllim,julim do 71 i=illim,iulim 71 v2(i,j,k)=v2(i,j,k) +vcor31(f2(i,j,k), 1 x(i,j-2,k),x(i,j-1,k),x(i,j,k),x(i,j+1,k), 1 .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,-1,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) enddo enddo end if if (topedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2,k),x(i,mp-1,k),x(i,mp,k),x(i,mp+2,k), 1 .5*(h(i,mp-1,k)+h(i,mp,k))) enddo enddo end if endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 pbc*x(i,1-j3,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2*j3,k),x(i,mp-j3,k),x(i,mp,k),pbc*x(i,mp+j3,k), 1 .5*(h(i,mp-j3,k)+h(i,mp,k))) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) jllim = 1 + (2-ibcy)*botedge julim = mp - (1-ibcy)*topedge illim = 1 + leftedge iulim = np - rightedge #else jllim = 1+botedge julim = mp illim = 1 iulim = np #endif do 72 k=2,n3-2 do 72 j=jllim,julim do 72 i=illim,iulim 72 v2(i,j,k)=v2(i,j,k) 1 +vcor32(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j-1,k)) * +abs(x(i-1,j-1,k)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j-1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) 1 +vcor32(f2(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i,j-1,k+1)) * +abs(x(i,j-1,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i,j-1,k+1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) 1 +vcor32(f2(1,j,k), * f1(1,j-1,k)+f1(2,j-1,k)+f1(2,j,k)+f1(1,j,k), * abs(x( 2,j,k))-abs(x(-1,j,k))-abs(x(2,j-1,k)) * +abs(x(-1,j-1,k)), abs(x(2,j,k))+abs(x(-1,j,k)) * +abs(x(2,j-1,k))+abs(x(-1,j-1,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) 1 +vcor32(f2(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(1,j,k+1))-abs(x(1,j,k-1))-abs(x(1,j-1,k+1)) * +abs(x(1,j-1,k-1)), abs(x(1,j,k+1))+abs(x(1,j,k-1)) * +abs(x(1,j-1,k+1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do 73 k=2,n3-2 do 73 j=jllim,julim do 73 i=illim,iulim 73 v2(i,j,k)=v2(i,j,k) + vcor33(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i+1,j-1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))-abs(x(i-1, j ,k+1)) * -abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1)), * abs(x(i+1,j-1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))+abs(x(i-1, j ,k+1)) * +abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) + vcor33(f2(1,j,k), * f1(1,j-1,k)+f1( 2 ,j-1,k)+f1( 2 ,j,k)+f1(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(2,j-1,k+1))-abs(x(-1,j-1,k+1)) * -abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))-abs(x(-1, j ,k+1)) * -abs(x(2, j ,k-1))+abs(x(-1, j ,k-1)), * abs(x(2,j-1,k+1))+abs(x(-1,j-1,k+1)) * +abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))+abs(x(-1, j ,k+1)) * +abs(x(2, j ,k-1))+abs(x(-1, j ,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) 1 +vcor32(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * abs(x(i+1,j,1))-abs(x(i-1,j,1))-abs(x(i+1,j-1,1)) * +abs(x(i-1,j-1,1)), abs(x(i+1,j,1))+abs(x(i-1,j,1)) * +abs(x(i+1,j-1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) 1 +vcor32(f2(i,j,1), * f3(i,j-1,1)+f3(i,j-1, 2 )+f3(i,j, 2 )+f3(i,j,1), * abs(x(i,j,2))-abs(x(i,j,n3-2))-abs(x(i,j-1,2)) * +abs(x(i,j-1,n3-2)), abs(x(i,j,2))+abs(x(i,j,n3-2)) * +abs(x(i,j-1,2))+abs(x(i,j-1,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) 1 +vcor32(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * abs(x(2,j,1))-abs(x(-1,j,1))-abs(x(2,j-1,1)) * +abs(x(-1,j-1,1)), abs(x(2,j,1))+abs(x(-1,j,1)) * +abs(x(2,j-1,1))+abs(x(-1,j-1,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) 1 +vcor32(f2(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(1,j,2))-abs(x(1,j,n3-2))-abs(x(1,j-1,2)) * +abs(x(1,j-1,n3-2)), abs(x(1,j,2))+abs(x(1,j,n3-2)) * +abs(x(1,j-1,2))+abs(x(1,j-1,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) + vcor33(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * f3(i,j-1,1)+f3( i ,j-1,2)+f3( i ,j,2)+f3(i,j,1), * abs(x(i+1,j-1, 2 ))-abs(x(i-1,j-1, 2 )) * -abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))-abs(x(i-1, j , 2 )) * -abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2)), * abs(x(i+1,j-1, 2 ))+abs(x(i-1,j-1, 2 )) * +abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))+abs(x(i-1, j , 2 )) * +abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) + vcor33(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(2,j-1, 2 ))-abs(x(-1,j-1, 2 )) * -abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))-abs(x(-1, j , 2 )) * -abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2)), * abs(x(2,j-1, 2 ))+abs(x(-1,j-1, 2 )) * +abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))+abs(x(-1, j , 2 )) * +abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k)),ampd(1,j,3)*max0(2-itr,0)) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * -abs(x(i-1,j,k-1))-abs(x(i-1,j,k)), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * +abs(x(i-1,j,k-1))+abs(x(i-1,j,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * -abs(x(i,j-1,k-1))-abs(x(i,j-1,k)), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * +abs(x(i,j-1,k-1))+abs(x(i,j-1,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k)),ampd(1,j,3)*max0(2-itr,0)) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * -abs(x(-1,j,k-1))-abs(x(-1,j,k)), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * +abs(x(-1,j,k-1))+abs(x(-1,j,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * -abs(x(1,j-1,k-1))-abs(x(1,j-1,k)), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * +abs(x(1,j-1,k-1))+abs(x(1,j-1,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1-1,j,k)=v3(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) end do end do end if #endif endif !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k)),ampd(1,1,3)*max0(2-itr,0)) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * -abs(x(i-1,1,k-1))-abs(x(i-1,1,k)), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * +abs(x(i-1,1,k-1))+abs(x(i-1,1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * -abs(x(i,-1,k-1))-abs(x(i,-1,k)), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * +abs(x(i,-1,k-1))+abs(x(i,-1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) end do end do end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k)),ampd(1,1,3)*max0(2-itr,0)) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * -abs(x(-1,1,k-1))-abs(x(-1,1,k)), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * +abs(x(-1,1,k-1))+abs(x(-1,1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * -abs(x(1,-1,k-1))-abs(x(1,-1,k)), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * +abs(x(1,-1,k-1))+abs(x(1,-1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1 ,k)=v3(1,1,k) v3( 1 ,n2m,k)=v3(1,1,k) #endif enddo end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) end do end if if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) end do end if if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) end do end if #endif endif !ibcx=1 endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim 531 v3(i,j,k)=v3(i,j,k) * -vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 81 k=3,n3-2 do 81 j=jllim,julim do 81 i=illim,iulim 81 v3(i,j,k)=v3(i,j,k) +vcor31(f3(i,j,k), 1 x(i,j,k-2),x(i,j,k-1),x(i,j,k),x(i,j,k+1), 1 .5*(h(i,j,k-1)+h(i,j,k))) if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v3(i,j,2)=v3(i,j,2) +vcor31(f3(i,j,2), 1 x(i,j,n3-2),x(i,j,1),x(i,j,2),x(i,j,3), 1 .5*(h(i,j,1)+h(i,j,2))) v3(i,j,n3-1)=v3(i,j,n3-1) +vcor31(f3(i,j,n3-1), 1 x(i,j,n3-3),x(i,j,n3-2),x(i,j,n3-1),x(i,j,2), 1 .5*(h(i,j,n3-2)+h(i,j,n3-1))) enddo enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 82 k=3-ibcz,n3-2+ibcz do 82 j=jllim,julim do 82 i=illim,iulim 82 v3(i,j,k)=v3(i,j,k) 1 +vcor32(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i,j+1,k-1)) * +abs(x(i,j-1,k-1)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i,j+1,k-1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) 1 +vcor32(f3(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j,k-1)) * +abs(x(i-1,j,k-1)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j,k-1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) 1 +vcor32(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i,2,k-1)) * +abs(x(i,-1,k-1)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i,2,k-1))+abs(x(i,-1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) 1 +vcor32(f3(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,1,k))-abs(x(i-1,1,k))-abs(x(i+1,1,k-1)) * +abs(x(i-1,1,k-1)), abs(x(i+1,1,k))+abs(x(i-1,1,k)) * +abs(x(i+1,1,k-1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 83 k=3-ibcz,n3-2+ibcz do 83 j=jllim,julim do 83 i=illim,iulim 83 v3(i,j,k)=v3(i,j,k) + vcor33(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j+1,k-1))-abs(x(i+1,j-1,k-1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))-abs(x(i+1,j-1, k )) * -abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k )), * abs(x(i+1,j+1,k-1))+abs(x(i+1,j-1,k-1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))+abs(x(i+1,j-1, k )) * +abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k ))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) + vcor33(f3(i,1,k), * f2(i,1,k-1)+f2(i, 2 ,k-1)+f2(i, 2 ,k)+f2(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,2,k-1))-abs(x(i+1,-1,k-1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))-abs(x(i+1,-1, k )) * -abs(x(i-1,2, k ))+abs(x(i-1,-1, k )), * abs(x(i+1,2,k-1))+abs(x(i+1,-1,k-1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))+abs(x(i+1,-1, k )) * +abs(x(i-1,2, k ))+abs(x(i-1,-1, k ))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 if(ibcx.eq.1) then if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) 1 +vcor32(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1, k ))-abs(x(1,j-1, k )) * -abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1)), * abs(x(1,j+1, k ))+abs(x(1,j-1, k )) * +abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) 1 +vcor32(f3(1,j,k), * f1(1,j,k-1)+f1(2,j,k-1)+f1(2,j,k)+f1(1,j,k), * abs(x(2,j, k ))-abs(x(-1,j, k )) * -abs(x(2,j,k-1))+abs(x(-1,j,k-1)), * abs(x(2,j, k ))+abs(x(-1,j, k )) * +abs(x(2,j,k-1))+abs(x(-1,j,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) 1 +vcor32(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1,2,k))-abs(x(1,-1,k))-abs(x(1,2,k-1))+abs(x(1,-1,k-1)), * abs(x(1,2,k))+abs(x(1,-1,k))+abs(x(1,2,k-1))+abs(x(1,-1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) 1 +vcor32(f3(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x(2,1,k))-abs(x(-1,1,k))-abs(x(2,1,k-1))+abs(x(-1,1,k-1)), * abs(x(2,1,k))+abs(x(-1,1,k))+abs(x(2,1,k-1))+abs(x(-1,1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) + vcor33(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * f1(1,j,k-1)+f1(2, j ,k-1)+f1(2, j ,k)+f1(1,j,k), * abs(x( 2,j+1,k-1))-abs(x( 2,j-1,k-1)) * -abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))-abs(x( 2,j-1, k )) * -abs(x(-1,j+1, k ))+abs(x(-1,j-1, k )), * abs(x( 2,j+1,k-1))+abs(x( 2,j-1,k-1)) * +abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))+abs(x( 2,j-1, k )) * +abs(x(-1,j+1, k ))+abs(x(-1,j-1, k ))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) + vcor33(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x( 2,2,k-1))-abs(x( 2,-1,k-1)) * -abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))-abs(x( 2,-1, k )) * -abs(x(-1,2, k ))+abs(x(-1,-1, k )), * abs(x( 2,2,k-1))+abs(x( 2,-1,k-1)) * +abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))+abs(x( 2,-1, k )) * +abs(x(-1,2, k ))+abs(x(-1,-1, k ))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !isor=3 #if (POLES == 0) COLD if (ibcx.eq.1) then COLD do k=1,n3m COLD do j=1,n2m COLD v1(1 ,j,k)=v1(n1m,j,k) COLD v1(n1,j,k)=v1(2 ,j,k) COLD end do COLD end do COLD end if COLD if (ibcy.eq.1) then COLD do k=1,n3m COLD do i=1,n1m COLD v2(i, 1,k)=v2(i,n2m,k) COLD v2(i,n2,k)=v2(i,2 ,k) COLD end do COLD end do COLD end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if #endif COLD if (iflg.ne.8) then COLD do j=1,n2m COLD do i=1,n1m COLD v3(i,j, 1)=-v3(i,j, 2)*(1-ibcz)+v3(i,j,n3m)*ibcz COLD v3(i,j,n3)=-v3(i,j,n3m)*(1-ibcz)+v3(i,j, 2 )*ibcz COLD enddo COLD enddo COLD end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) C----------------/ #else /* POLES */ C----------------/ do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mx(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mn(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mx(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mn(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=illim,np 402 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1,j,k)=f1(-1,j,k)*ibcx end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k)*ibcx end do end do end if C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) #endif #if (POLES == 0) jllim = 1 + 1*botedge #else jllim = 1 #endif do 403 k=1,n3m do 403 j=jllim,mp do 403 i=1,np 403 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k)*ibcy end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k)*ibcy end do end do end if C----------------/ #else /* POLES */ C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 4033 k=2,n3m do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=0. f3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2 )*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo endif do 404 k=1,n3m do 404 j=1,mp do 404 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 404 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)=pp(v1(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1., x(i-1,j,k))) 1 +amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1.,-x(i-1,j,k))) ) 2 -pn(v1(i,j,k))* 2 ( amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1., x(i ,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1.,-x(i ,j,k ))) ) enddo enddo enddo do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k)=pp(v2(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1., x(i,j-1,k))) 1 +amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1.,-x(i,j-1,k))) ) 1 -pn(v2(i,j,k))* 2 ( amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1., x(i,j ,k))) 2 +amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1.,-x(i,j ,k))) ) enddo enddo enddo do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)=pp(v3(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1., x(i,j,k-1))) 1 +amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1.,-x(i,j,k-1))) ) 1 -pn(v3(i,j,k))* 2 ( amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1., x(i,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1.,-x(i,j,k ))) ) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3 ,k) end do end do end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.1) then do j=1,mp do i=1,np v3(i,j, 1)=0. v3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2 )*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo endif 30 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(34) #endif return end subroutine mpdatm3(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(nonos=1,idiv=0) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/diffus/ sk(l),skr(l),sls data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(35) #endif ! do j=1,mp ! do i=1,np ! if(iflg.eq.31.or.iflg.eq.32) then !mod bbc ! x(i,j, 1) = 0 ! x(i,j,l) = 0. ! endif ! if(iflg.eq.33) then ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! endif ! end do ! end do call update(x,np,mp,l,np,mp,iup) iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy ibcxy=ibcx*ibcy #else ibox=0 iboy=0 ibcxy=1 #endif itmx=2-liner iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do k=1,n3m do j=jllim,julim do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+(1-ibcz)*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+(1-ibcz)*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + botedge julim2 = mp - topedge do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif c1=1. c2=0. do 30 itr=1,itmx if((itr.eq.1).and.(ibcxy.eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim f1(i,j,k)=donor(c1*x(i-1,j,k)+c2,c1*x(i,j,k)+c2,v1(i,j,k)) end do end do end do c if(itr.eq.1.and.kampd(1).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=1,mp do i=illim,iulim c ampdx=c1*ampd(1,j,1)*0.5*(h(i,j,k)+h(i-1,j,k)) ampdx=sk(k)*0.5*(h(i,j,k)+h(i-1,j,k))*dt*dxi**2 f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp c special icylind, tank c f1(1 ,j,k)=-f1(2,j,k) f1(1 ,j,k)=donor(c1*bcx(j,k,1)+c2,c1*x(1,j,k)+c2,v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp c special tank c f1(np+1,j,k)=-f1(np,j,k) f1(np+1,j,k)= . donor(c1*x(np,j,k)+c2,c1*bcx(j,k,2)+c2,v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do k=1,n3m do j=jllim,julim do i=1,np f2(i,j,k)=donor(c1*x(i,j-1,k)+c2,c1*x(i,j,k)+c2,v2(i,j,k)) end do end do end do c if(itr.eq.1.and.kampd(2).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=jllim,julim do i=1,np c ampdy=c1*0.5*(ampd(1,j,2)+ampd(1,j-1,2)) c & *0.5*( h(i,j,k)+ h(i,j-1,k)) ampdy=sk(k)*0.5*( h(i,j,k)+ h(i,j-1,k))*dt*dyi**2 f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np c f2(i,1,k)=donor(c1*bcy(i,k,1)+c2,c1*x(i,1,k)+c2,v2(i,1,k)) f2(i,1,k)=-f2(i,2,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np c f2(i,mp+1,k)= c . donor(c1*x(i,mp,k)+c2,c1*bcy(i,k,2)+c2,v2(i,mp+1,k)) f2(i,mp+1,k)=-f2(i,mp,k) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(c1*x(i,j,k-1)+c2,c1*x(i,j,k)+c2,v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=2,n3m do j=1,mp do i=1,np c ampdz=c1*ampd(1,j,3)*0.5*(h(i,j,k)+h(i,j,k-1)) ampdz=sk(k)*0.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(c1*x(i,j, 1 )+c2,c1*x(i,j, 1 )+c2,v3(i,j,1 )) f3(i,j,n3)=donor(c1*x(i,j,n3m)+c2,c1*x(i,j,n3m)+c2,v3(i,j,n3)) end do end do else do j=1,mp do i=1,np if (iflg.eq.0) then c if (itr.eq.itmx.and.iflg.eq.1) then c-------- special for solar luminosity dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi hfbt=hf00 gactp=1./(gi(i,j)*gmus(n3m)) + *((1-icylind)*gmm(i,j,n3m)**2*cosa(i,j) + +icylind*gmm(i,j,n3m))*dnmi * dt*dzi hftp=hf00*(gacbt/gactp) C + *23. f3(i,j, 1)=2.*hfbt*gacbt-f3(i,j, 2) f3(i,j,n3)=2.*hftp*gactp-f3(i,j,n3m) c f3(i,j,n3)= f3(i,j,n3m) else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz endif enddo enddo end if do k=1,n3m do j=1,mp do i=1,np x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) end do end do end do if(itr.eq.itmx) go to 6 c1=0. c2=1. #if (POLES == 0) iulim = np + rightedge julim = mp + topedge #else iulim = np julim = mp + topedge #endif do k=1,n3m do j=1,mp do i=1,iulim f1(i,j,k)=v1(i,j,k) v1(i,j,k)=0. end do end do end do do k=1,n3m do j=1,julim do i=1,np f2(i,j,k)=v2(i,j,k) v2(i,j,k)=0. end do end do end do do k=1,n3 do j=1,mp do i=1,np f3(i,j,k)=v3(i,j,k) v3(i,j,k)=0. end do end do end do call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #endif do k=2,n3-2 do j=jllim,julim do i=illim,iulim v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * x(i-1,j-1,k),x(i,j-1,k),x(i-1,j+1,k),x(i,j+1,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * x(i-1,j,k-1),x(i,j,k-1),x(i-1,j,k+1),x(i,j,k+1), * .5*(h(i-1,j,k)+h(i,j,k))) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * x(i-1,-1,k),x(i,-1,k),x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif end if C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * pbc*x(i-1,1-j3,k),pbc*x(i,1-j3,k), * x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) enddo enddo end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=vdyf(x(i-1,mp,k),x(i,mp,k),f1(i,mp,k), * .5*(h(i-1,mp,k)+h(i,mp,k))) * +vcorr(f1(i,mp,k), * f2(i-1,mp,k)+f2(i-1,mp+j3,k)+f2(i,mp+j3,k)+f2(i,mp,k), * x(i-1,mp-j3,k),x(i,mp-j3,k), * pbc*x(i-1,mp+j3,k),pbc*x(i,mp+j3,k), * .5*(h(i-1,mp,k)+h(i,mp,k))) * +vcorr(f1(i,mp,k), * f3(i-1,mp,k)+f3(i-1,mp,k+1)+f3(i,mp,k+1)+f3(i,mp,k), * x(i-1,mp,k-1),x(i,mp,k-1),x(i-1,mp,k+1),x(i,mp,k+1), * .5*(h(i-1,mp,k)+h(i,mp,k))) enddo enddo end if C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * x(i-1,j,n3-2),x(i,j,n3-2),x(i-1,j,2),x(i,j,2), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * x(i-1,1,n3-2),x(i,1,n3-2),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=v1(i,1,1) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp ,1) enddo end if #endif endif !ibcy=1 C----------------/ #endif /* no POLES=1 for ibcz=1 */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * x(i-1,j-1,n3m),x(i,j-1,n3m),x(i-1,j+1,n3m),x(i,j+1,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * x(i-1,-1,n3m),x(i,-1,n3m),x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) enddo end if #endif endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * pbc*x(i-1,1-j3,1),pbc*x(i,1-j3,1), * x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * pbc*x(i-1,1-j3,n3m),pbc*x(i,1-j3,n3m), * x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) enddo end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp,1)=vdyf(x(i-1,mp,1),x(i,mp,1),f1(i,mp,1), * .5*(h(i-1,mp,1)+h(i,mp,1))) * +vcorr(f1(i,mp,1), * f2(i-1,mp,1)+f2(i-1,mp+1,1) * +f2(i,mp+1,1)+f2(i,mp,1), * x(i-1,mp-j3,1),x(i,mp-j3,1), * pbc*x(i-1,mp+j3,1),pbc*x(i,mp+j3,1), * .5*(h(i-1,mp,1)+h(i,mp,1))) v1(i,mp,n3m)=vdyf(x(i-1,mp,n3m),x(i,mp,n3m),f1(i,mp,n3m), * .5*(h(i-1,mp,n3m)+h(i,mp,n3m))) * +vcorr(f1(i,mp,n3m), * f2(i-1,mp,n3m)+f2(i-1,mp+j3,n3m) * +f2(i,mp+j3,n3m)+f2(i,mp,n3m), * x(i-1,mp-j3,n3m),x(i,mp-j3,n3m), * pbc*x(i-1,mp+j3,n3m),pbc*x(i,mp+j3,n3m), * .5*(h(i-1,mp,n3m)+h(i,mp,n3m))) enddo end if C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + iboy*botedge julim = mp - iboy*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) 511 v1(i,j,k)=v1(i,j,k)+(pp(v1d)*x(i-1,j,k)-pn(v1d)*x(i,j,k)) endif c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp #else illim = 1 iulim = np jllim = 1 + botedge julim = mp #endif do k=2,n3-2 do j=jllim,julim do i=illim,iulim v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * x(i-1,j-1,k),x(i-1,j,k),x(i+1,j-1,k),x(i+1,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * x(i,j-1,k-1),x(i,j,k-1),x(i,j-1,k+1),x(i,j,k+1), * .5*(h(i,j-1,k)+h(i,j,k))) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * x(-1,j-1,k),x(-1,j,k),x(2,j-1,k),x(2,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif end do end do end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif else !ibcx=0 if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) v2(n1m,j,k)=vdyf(x(n1m,j-1,k),x(n1m,j,k),f2(n1m,j,k), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) * +vcorr(f2(n1m,j,k), * f3(n1m,j-1,k)+f3(n1m,j,k)+f3(n1m,j,k+1)+f3(n1m,j-1,k+1), * x(n1m,j-1,k-1),x(n1m,j,k-1),x(n1m,j-1,k+1),x(n1m,j,k+1), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=vdyf(x(np,j-1,k),x(np,j,k),f2(np,j,k), * .5*(h(np,j-1,k)+h(np,j,k))) * +vcorr(f2(np,j,k), * f3(np,j-1,k)+f3(np,j,k)+f3(np,j,k+1)+f3(np,j-1,k+1), * x(np,j-1,k-1),x(np,j,k-1),x(np,j-1,k+1),x(np,j,k+1), * .5*(h(np,j-1,k)+h(np,j,k))) end do end do end if #endif end if !ibcx test C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+j3,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * x(i,j-1,n3-2),x(i,j,n3-2),x(i,j-1,2),x(i,j,2), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * x(1,j-1,n3-2),x(1,j,n3-2),x(1,j-1,2),x(1,j,2), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=v2(1,j,1) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* no POLES=1 for ibcz=1 */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * x(i-1,j-1,n3m),x(i-1,j,n3m),x(i+1,j-1,n3m),x(i+1,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * x(-1,j-1,n3m),x(-1,j,n3m),x(2,j-1,n3m),x(2,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo end if ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 ,1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+j3,1 )= 0. v2(i,mp+j3,n3m)= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + j3*botedge julim = mp #else illim = 1 iulim = np jllim = 1 julim = mp + j3*topedge #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim v2d=-vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) 521 v2(i,j,k)=v2(i,j,k)+(pp(v2d)*x(i,j-1,k)-pn(v2d)*x(i,j,k)) endif c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 + botedge julim = mp - topedge #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * x(i-1,j,k-1),x(i-1,j,k),x(i+1,j,k-1),x(i+1,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * x(i,j-1,k-1),x(i,j-1,k),x(i,j+1,k-1),x(i,j+1,k), * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * x(-1,j,k-1),x(-1,j,k),x(2,j,k-1),x(2,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * x(1,j-1,k-1),x(1,j-1,k),x(1,j+1,k-1),x(1,j+1,k), * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo endif #endif end if !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * x(i,-1,k-1),x(i,-1,k),x(i,2,k-1),x(i,2,k), * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * x(-1,1,k-1),x(-1,1,k),x(2,1,k-1),x(2,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * x(1,-1,k-1),x(1,-1,k),x(1,2,k-1),x(1,2,k), * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1,k)=v3(1,1,k) v3( 1,n2m,k)=v3(1,1,k) #endif end do end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) enddo endif if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) enddo endif if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) enddo endif #endif end if !ibcx=1 end if !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3m do i=1,np v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * + vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * + vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,1+j3,k-1)+f2(i,1+j3,k)+f2(i,1,k), * pbc*x(i,1-j3,k-1),pbc*x(i,1-j3,k),x(i,1+j3,k-1),x(i,1+j3,k), * .5*(h(i,1,k-1)+h(i,1,k))) enddo enddo endif if (topedge.eq.1) then do k=2,n3m do i=1,np v3(i,mp,k)=vdyf(x(i,mp,k-1),x(i,mp,k),f3(i,mp,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) * + vcorr(f3(i,mp,k), * f1(i,mp,k-1)+f1(i,mp,k)+f1(i+1,mp,k)+f1(i+1,mp,k-1), * x(i-1,mp,k-1),x(i-1,mp,k),x(i+1,mp,k-1),x(i+1,mp,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) * + vcorr(f3(i,mp,k), * f2(i,mp,k-1)+f2(i,mp+j3,k-1)+f2(i,mp+j3,k)+f2(i,mp,k), * x(i,mp-j3,k-1),x(i,mp-j3,k),pbc*x(i,mp+j3,k-1),pbc*x(i,mp+j3,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim v2d=-vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) 531 v3(i,j,k)=v3(i,j,k)+(pp(v2d)*x(i,j,k-1)-pn(v2d)*x(i,j,k)) endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) enddo enddo end if end if if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i,1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) enddo enddo end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz end do end do end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) #else jllim = 1 + botedge julim = mp - topedge do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np im = i - 1 ip = i + 1 do j=jllim,julim jm = j - j3 jp = j + j3 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k ),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km),mx(i,j,k)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k ),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km),mn(i,j,k)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k ),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km),mx(i,1,k)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k ),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km),mn(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k ),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km),mx(i,mp,k)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k ),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km),mn(i,mp,k)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) iulim = np + rightedge julim = mp + j3*topedge #else iulim = np julim = mp #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=1,iulim 402 f1(i,j,k)=donor(c2,c2,v1(i,j,k)) do 403 k=1,n3m do 403 j=1,julim do 403 i=1,np 403 f2(i,j,k)=donor(c2,c2,v2(i,j,k)) do 4033 k=1,n3 do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(c2,c2,v3(i,j,k)) #if (POLES == 0) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if #else call updatelr(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if do 444 k=1,n3m do 444 j=1,mp do 444 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 444 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + botedge julim = mp #else illim = 1 iulim = np jllim = 1 julim = mp + topedge #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k)= pp(v1(i,j,k))*amin1(1.,cp(i,j,k),cn(i-1,j,k)) * -pn(v1(i,j,k))*amin1(1.,cp(i-1,j,k),cn(i,j,k)) end do end do end do CAUTION: the following loop is coded to get around an apparent compiler problem on the T3D. do k=1,n3m do j=jllim,julim do i=1,np ct3d if (v2(i,j,k).ge.0.) then ct3d v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) ct3d else ct3d v2(i,j,k)=-pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) ct3d end if v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) . -pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) end do end do end do do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)= pp(v3(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j,k-1)) * -pn(v3(i,j,k))*amin1(1.,cp(i,j,k-1),cn(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1 ,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) end do end do end if end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo end if endif 30 continue 6 continue c optional removal of roundoff error negatives in positive fileds c if(iflg.lt.2.or.iflg.gt.5) then c do k=1,l c do j=1,m c do i=1,n c x(i,j,k)=amax1(0.,x(i,j,k)) c enddo c enddo c enddo c endif c goto 999 c optional enforcing of perodicity cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc #if (POLES == 0) if (ibcx.eq.1) then call updatelr(x,np,mp,L,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp x(np,j,k)=x(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(x,np,mp,L,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np x(i,mp,k)=x(i,mp+1,k) end do end do end if end if #endif if (ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(35) #endif return end subroutine mpdatm3B(u1,u2,u3,x,h,iflg,div) include 'param.nml' include 'msg.inc' parameter(nonos=1,idiv=0) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . tempx(1-ih:np+ih, 1-ih:mp+ih, l), . div(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn real ampdx(mp),ampdy(mp),ampdz(mp) !factors for polar absorber attenuation c common/mpfil/ liner,mpfl,ampd0(3) !mod filters common/mpfil/ liner,mpfl,ampd0(3),ampd(mp,3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/realtp/ zsib(1-ih:nibp+ih,1-ih:mibp+ih,lib),tsibi data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r,amp1)=(abs(a)-a**2/r+2.*amp1*r)*rat2(x1,x2) c vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) !mod filters cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(35) #endif call update(x,np,mp,l,np,mp,iup) do k=1,n3m do j=1,mp do i=1,np div(i,j,k)=x(i,j,k) tempx(i,j,k)=x(i,j,k) end do end do end do ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz ibcxy=ibcx*ibcy itmx=2-liner iprec=0 if(iflg.eq.21) iprec=1 !qr, qia, qib do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do illim = 1 + leftedge do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k) = u1(i,j,k) end do end do end do if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if jllim = 1 + 1*botedge do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+(1-ibcz)*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+(1-ibcz)*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do endif c1=1. c2=0. do 30 itr=1,itmx if((itr.eq.1).and.(ibcxy.eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) COLD call update(x,np,mp,l,np,mp,iup) ilft=1+leftedge*1 do j=1,mp ampdx(j)=c1*ampd(j,1) enddo do k=1,n3m do j=1,mp do i=ilft,np f1(i,j,k)=donor(c1*x(i-1,j,k)+c2,c1*x(i,j,k)+c2,v1(i,j,k)) . -ampdx(j)*.5*(h(i,j,k)+h(i-1,j,k))*(x(i,j,k)-x(i-1,j,k)) !mod filters end do end do end do if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp c special icylind, tank c f1(1 ,j,k)=-f1(2,j,k) f1(1 ,j,k)=donor(c1*bcx(j,k,1)+c2,c1*x(1,j,k)+c2,v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp c special tank c f1(np+1,j,k)=-f1(np,j,k) f1(np+1,j,k)= . donor(c1*x(np,j,k)+c2,c1*bcx(j,k,2)+c2,v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif jbot=1+botedge*1 do j=1,mp ampdy(j)=c1*ampd(j,2) enddo do k=1,n3m do j=jbot,mp do i=1,np f2(i,j,k)=donor(c1*x(i,j-1,k)+c2,c1*x(i,j,k)+c2,v2(i,j,k)) . -ampdy(j)*.5*(h(i,j,k)+h(i,j-1,k))*(x(i,j,k)-x(i,j-1,k)) !mod filters end do end do end do if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=donor(c1*bcy(i,k,1)+c2,c1*x(i,1,k)+c2,v2(i,1,k)) c f2(i,1,k)=-f2(i,2,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)= . donor(c1*x(i,mp,k)+c2,c1*bcy(i,k,2)+c2,v2(i,mp+1,k)) c f2(i,mp+1,k)=-f2(i,mp,k) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif do j=1,mp ampdz(j)=c1*ampd(j,3) enddo do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(c1*x(i,j,k-1)+c2,c1*x(i,j,k)+c2,v3(i,j,k)) . -ampdz(j)*.5*(h(i,j,k)+h(i,j,k-1))*(x(i,j,k)-x(i,j,k-1)) !mod filters if(iprec.eq.1) then frain=-0.01*5. do j=1,mp do i=1,np f3(i,j, 1)=donor(c1*x(i,j, 1 )+c2,c1*x(i,j, 1 )+c2,v3(i,j,1 )) f3(i,j,n3)=donor(c1*x(i,j,n3m)+c2,c1*x(i,j,n3m)+c2,v3(i,j,n3)) csp f3(i,j, 1)=-f3(i,j, 2) csp if(zsib(i,j,n3m).lt.0.) then csp f3(i,j,n3)=2.*c1*frain-f3(i,j,n3m) csp else csp f3(i,j,n3)=-f3(i,j,n3m) csp endif end do end do else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo end if do k=1,n3m do j=1,mp do i=1,np x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) end do end do end do if(itr.eq.itmx) then do k=1,n3m do j=1,mp do i=1,np div(i,j,k)=x(i,j,k)-div(i,j,k) x(i,j,k)=tempx(i,j,k) end do end do end do go to 6 endif c1=0. c2=1. iulim = np + 1*rightedge julim = mp + 1*topedge do k=1,n3m do j=1,mp do i=1,iulim f1(i,j,k)=v1(i,j,k) v1(i,j,k)=0. end do end do end do do k=1,n3m do j=1,julim do i=1,np f2(i,j,k)=v2(i,j,k) v2(i,j,k)=0. end do end do end do do k=1,n3 do j=1,mp do i=1,np f3(i,j,k)=v3(i,j,k) v3(i,j,k)=0. end do end do end do c------------ compute antidiffusive velocities in x direction c------------ call update(x,np,mp,l,np,mp,iup) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) illim = 1 + leftedge iulim = np jllim = 1 + botedge julim = mp - topedge do k=2,n3-2 do j=jllim,julim do i=illim,iulim v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k)),ampdx(j)) !mod filters * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * x(i-1,j-1,k),x(i,j-1,k),x(i-1,j+1,k),x(i,j+1,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * x(i-1,j,k-1),x(i,j,k-1),x(i-1,j,k+1),x(i,j,k+1), * .5*(h(i-1,j,k)+h(i,j,k))) end do end do end do c------------ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k)),ampdx(1)) !mod filters * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * x(i-1,-1,k),x(i,-1,k),x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif end if c------------ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampdx(j)) !mod filters * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * x(i-1,j,n3-2),x(i,j,n3-2),x(i-1,j,2),x(i,j,2), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampdx(1)) !mod filters * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * x(i-1,1,n3-2),x(i,1,n3-2),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=v1(i,1,1) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp ,1) enddo end if #endif endif !ibcy=1 else !ibcz test do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampdx(j)) !mod filters * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m)),ampdx(j)) !mod filters * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * x(i-1,j-1,n3m),x(i,j-1,n3m),x(i-1,j+1,n3m),x(i,j+1,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampdx(1)) !mod filters * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m)),ampdx(1)) !mod filters * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * x(i-1,-1,n3m),x(i,-1,n3m),x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) enddo end if #endif endif !ibcy=1 endif !ibcz=1 c------------ if(idiv.eq.1) then illim = 1 + leftedge iulim = np jllim = 1 + iboy*botedge julim = mp - iboy*topedge do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) 511 v1(i,j,k)=v1(i,j,k)+(pp(v1d)*x(i-1,j,k)-pn(v1d)*x(i,j,k)) endif c------------ compute antidiffusive velocities in y direction c------------ illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp do k=2,n3-2 do j=jllim,julim do i=illim,iulim v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k)),ampdy(j)) !mod filters * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * x(i-1,j-1,k),x(i-1,j,k),x(i+1,j-1,k),x(i+1,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * x(i,j-1,k-1),x(i,j,k-1),x(i,j-1,k+1),x(i,j,k+1), * .5*(h(i,j-1,k)+h(i,j,k))) end do end do end do c------------ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)),ampdy(j)) !mod filters * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * x(-1,j-1,k),x(-1,j,k),x(2,j-1,k),x(2,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif end do end do end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif else !ibcx=0 if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)),ampdy(j)) !mod filters * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) v2(n1m,j,k)=vdyf(x(n1m,j-1,k),x(n1m,j,k),f2(n1m,j,k), * .5*(h(n1m,j-1,k)+h(n1m,j,k)),ampdy(j)) !mod filters * +vcorr(f2(n1m,j,k), * f3(n1m,j-1,k)+f3(n1m,j,k)+f3(n1m,j,k+1)+f3(n1m,j-1,k+1), * x(n1m,j-1,k-1),x(n1m,j,k-1),x(n1m,j-1,k+1),x(n1m,j,k+1), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=vdyf(x(np,j-1,k),x(np,j,k),f2(np,j,k), * .5*(h(np,j-1,k)+h(np,j,k)),ampdy(j)) !mod filters * +vcorr(f2(np,j,k), * f3(np,j-1,k)+f3(np,j,k)+f3(np,j,k+1)+f3(np,j-1,k+1), * x(np,j-1,k-1),x(np,j,k-1),x(np,j-1,k+1),x(np,j,k+1), * .5*(h(np,j-1,k)+h(np,j,k))) end do end do end if #endif end if !ibcx test c------------ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)),ampdy(j)) !mod filters * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * x(i,j-1,n3-2),x(i,j,n3-2),x(i,j-1,2),x(i,j,2), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)),ampdy(j)) !mod filters * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * x(1,j-1,n3-2),x(1,j,n3-2),x(1,j-1,2),x(1,j,2), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=v2(1,j,1) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np ,j,1) end do end if #endif endif !ibcx=1 else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)),ampdy(j)) !mod filters * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m)),ampdy(j)) !mod filters * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * x(i-1,j-1,n3m),x(i-1,j,n3m),x(i+1,j-1,n3m),x(i+1,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)),ampdy(j)) !mod filters * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m)),ampdy(j)) !mod filters * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * x(-1,j-1,n3m),x(-1,j,n3m),x(2,j-1,n3m),x(2,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo end if ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 endif !ibcz=1 c------------ if(idiv.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + 1*botedge julim = mp do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim v2d=-vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) 521 v2(i,j,k)=v2(i,j,k)+(pp(v2d)*x(i,j-1,k)-pn(v2d)*x(i,j,k)) endif c------------ compute antidiffusive velocities in z direction c------------ illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k)),ampdz(j)) !mod filters * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * x(i-1,j,k-1),x(i-1,j,k),x(i+1,j,k-1),x(i+1,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * x(i,j-1,k-1),x(i,j-1,k),x(i,j+1,k-1),x(i,j+1,k), * .5*(h(i,j,k-1)+h(i,j,k))) if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k)),ampdz(j)) !mod filters * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * x(-1,j,k-1),x(-1,j,k),x(2,j,k-1),x(2,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * x(1,j-1,k-1),x(1,j-1,k),x(1,j+1,k-1),x(1,j+1,k), * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo endif #endif end if !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k)),ampdz(1)) !mod filters * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * x(i,-1,k-1),x(i,-1,k),x(i,2,k-1),x(i,2,k), * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k)),ampdz(1)) !mod filters * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * x(-1,1,k-1),x(-1,1,k),x(2,1,k-1),x(2,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * x(1,-1,k-1),x(1,-1,k),x(1,2,k-1),x(1,2,k), * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1,k)=v3(1,1,k) v3( 1,n2m,k)=v3(1,1,k) #endif end do end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) enddo endif if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) enddo endif if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) enddo endif #endif end if !ibcx=1 end if !ibcy=1 if(idiv.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim v2d=-vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) 531 v3(i,j,k)=v3(i,j,k)+(pp(v2d)*x(i,j,k-1)-pn(v2d)*x(i,j,k)) endif if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) enddo enddo end if end if if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i,1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) enddo enddo end if end if if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz end do end do end if if(nonos.eq.1) then c non-osscilatory option do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) iulim = np + 1*rightedge julim = mp + 1*topedge do 402 k=1,n3m do 402 j=1,mp do 402 i=1,iulim 402 f1(i,j,k)=donor(c2,c2,v1(i,j,k)) do 403 k=1,n3m do 403 j=1,julim do 403 i=1,np 403 f2(i,j,k)=donor(c2,c2,v2(i,j,k)) do 4033 k=1,n3 do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(c2,c2,v3(i,j,k)) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if do 444 k=1,n3m do 444 j=1,mp do 444 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 444 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) illim = 1 + leftedge jllim = 1 + 1*botedge do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)= pp(v1(i,j,k))*amin1(1.,cp(i,j,k),cn(i-1,j,k)) * -pn(v1(i,j,k))*amin1(1.,cp(i-1,j,k),cn(i,j,k)) end do end do end do CAUTION: the following loop is coded to get around an apparent compiler problem on the T3D. do k=1,n3m do j=jllim,mp do i=1,np ct3d if (v2(i,j,k).ge.0.) then ct3d v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) ct3d else ct3d v2(i,j,k)=-pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) ct3d end if v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) . -pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) end do end do end do do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)= pp(v3(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j,k-1)) * -pn(v3(i,j,k))*amin1(1.,cp(i,j,k-1),cn(i,j,k)) end do end do end do if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1 ,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) end do end do end if end if if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo end if endif 30 continue 6 continue c optional removal of roundoff error negatives in positive fileds c if(iflg.lt.2.or.iflg.gt.5) then c do k=1,l c do j=1,m c do i=1,n c x(i,j,k)=amax1(0.,x(i,j,k)) c enddo c enddo c enddo c endif c goto 999 c optional enforcing of perodicity cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(x,np,mp,L,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp x(np,j,k)=x(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(x,np,mp,L,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np x(i,mp,k)=x(i,mp+1,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(35) #endif return end subroutine mp3bc(x,iflg,bcx,bcy,n1,n2,n3) include 'param.nml' include 'msg.inc' common/profB/ prfb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) dimension x(1-ih:np+ih,1-ih:mp+ih,l), . bcx(1-ih:mp+ih,n3,2), . bcy(1-ih:np+ih,n3,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/znave/ uza(mp,l,3),thza(mp,l),qvza(mmsp,lms), . bza(mmhdp,lmhd,3) #if (TIMEPLT == 1) call ttbeg(36) #endif #if (POLES == 0) if(iflg.eq.1) then ! ---> th if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(1,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(mp,k) enddo enddo end if else if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if endif goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb( 1,j,k,iflg-30) bcx(j,k,2)=prfb( 0,j,k,iflg-30) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb(np+1,j,k,iflg-30) bcx(j,k,2)=prfb(np,j,k,iflg-30) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i, 1,k,iflg-30) bcy(i,k,2)=prfb(i, 0,k,iflg-30) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i,mp+1,k,iflg-30) bcy(i,k,2)=prfb(i,mp,k,iflg-30) enddo enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.11) then ! ---> thf if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if goto 999 endif #endif if(iflg.eq.2.or.iflg.eq.3) then ! ---> u0.v0 if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,iflg) bcx(j,k,2)=prf( 0,j,k,iflg) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,iflg) bcx(j,k,2)=prf(np,j,k,iflg) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,iflg) C +uza(1,k,iflg-1) bcy(i,k,2)=prf(i, 0,k,iflg) C +uza(0,k,iflg-1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,iflg) C +uza(mp+1,k,iflg-1) bcy(i,k,2)=prf(i,mp,k,iflg) C +uza(mp,k,iflg-1) enddo enddo end if goto 999 endif if(iflg.eq.51) then ! ---> fox if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bcx(j,k,1)=g11w*prf(1,j,k,2)+g21w*prf(1,j,k,3)+strxd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bcx(j,k,2)=g11w*prf(0,j,k,2)+g21w*prf(0,j,k,3)+strxd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bcx(j,k,1)=g11e*prf(np+1,j,k,2)+g21e*prf(np+1,j,k,3)+strxd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bcx(j,k,2)=g11e*prf(np,j,k,2)+g21e*prf(np,j,k,3)+strxd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g11s=strxx(i,1)*g110s g21s=strxy(i,1)*g220s bcy(i,k,1)=g11w*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g11s=strxx(i,0)*g110s g21s=strxy(i,0)*g220s bcy(i,k,2)=g11w*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g11n=strxx(i,mp+1)*g110n g21n=strxy(i,mp+1)*g220n bcy(i,k,1)=g11n*prf(i,mp+1,k,2)+g21n*prf(i,mp+1,k,3)+strxd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g11n=strxx(i,mp)*g110n g21n=strxy(i,mp)*g220n bcy(i,k,2)=g11n*prf(i,mp,k,2)+g21n*prf(i,mp,k,3)+strxd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.52) then ! ---> foy if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g12w=stryx(1,j)*g110w g22w=stryy(1,j)*g220w bcx(j,k,1)=g12w*prf(1,j,k,2)+g22w*prf(1,j,k,3)+stryd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g12w=stryx(0,j)*g110w g22w=stryy(0,j)*g220w bcx(j,k,2)=g12w*prf(0,j,k,2)+g22w*prf(0,j,k,3)+stryd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g12e=stryx(np+1,j)*g110e g22e=stryy(np+1,j)*g220e bcx(j,k,1)=g12e*prf(np+1,j,k,2)+g22e*prf(np+1,j,k,3)+stryd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g12e=stryx(np,j)*g110e g22e=stryy(np,j)*g220e bcx(j,k,2)=g12e*prf(np,j,k,2)+g22e*prf(np,j,k,3)+stryd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bcy(i,k,1)=g12s*prf(i,1,k,2)+g22s*prf(i,1,k,3)+stryd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bcy(i,k,2)=g12s*prf(i,0,k,2)+g22s*prf(i,0,k,3)+stryd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bcy(i,k,1)=g12n*prf(i,mp+1,k,2)+g22n*prf(i,mp+1,k,3)+stryd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bcy(i,k,2)=g12n*prf(i,mp,k,2)+g22n*prf(i,mp,k,3)+stryd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then ! w0| foz |ftf,fqv,fqc,fqr if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(1,k,3) bcy(i,k,2)=0. C +uza(0,k,3) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(mp+1,k,3) bcy(i,k,2)=0. C +uza(mp,k,3) enddo enddo end if goto 999 endif #if (MOISTMOD > 0) if(iflg.eq.6) then ! ---> qv if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve( 1,j,k) bcx(j,k,2)=qve( 0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(np+1,j,k) bcx(j,k,2)=qve(np,j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i, 1,k) bcy(i,k,2)=qve(i, 0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i,mp+1,k) bcy(i,k,2)=qve(i,mp,k) enddo enddo end if goto 999 endif if(iflg.ge.7) then ! ---> qc if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo end if goto 999 endif #endif #endif 999 continue #if (TIMEPLT == 1) call ttend(36) #endif return end #endif /* J3DIM == 1 */ #endif /* SEMILAG == 0 */ #if (SEMILAG == 1) subroutine interp(xf,xd1,xd2,xd3,ifirst) include 'param.nml' include 'msg.inc' dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l), . xd3(1-ih:np+ih,1-ih:mp+ih,l) C return #if (TIMEPLT == 1) call ttbeg(37) #endif #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ifirst) #else call inter2(xf,xd1,xd3,ifirst) #endif #if (TIMEPLT == 1) call ttend(37) #endif return end #if (J3DIM == 0) subroutine inter2(xf,xd1,xd2,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' include 'param.nml' include 'msg.inc' parameter(nonos=1) c NOTE: ihlag must be >= (ior + 1) dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l) parameter(n1=n,n2=l,nn=n1*n2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(ixa=(np+2*ihlag+2*ior)*(mp+2*ihlag+2*ior)*(n2+2*ior)) parameter(ifree=14*iarray-(2*ior+1)*iarray-ixa) common/blank/ x(1-ior-ihlag:np+ior+ihlag, . 1-ior-ihlag:mp+ior+ihlag, . 1-ior:n2+ior), . z(1-ih:np+ih,1-ih:mp+ih,l, -ior:ior), . ig0(1-ih:np+ih,1-ih:mp+ih,l), . jg0(1-ih:np+ih,1-ih:mp+ih,l), . scr(ifree) #if (PARALLEL>0) common /slag/ iloc(np,mp,l,-ior:ior),jloc(np,mp,l,-ior:ior) #endif real mx,mn data ep/ 1.e-10/ common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 tr2(y1,y2,a)=a*.5*(y1+y2)-a**2*.5*(y2-y1) tr4(ym1,y0,yp1,yp2,a)=a/12.*(7.*(yp1+y0)-(yp2+ym1)) 1 -a**2/24.*(15.*(yp1-y0)-(yp2-ym1))-a**3/12.*((yp1+y0) 2 -(yp2+ym1))+a**4/24.*(3.*(yp1-y0)-(yp2-ym1)) tr6(ym2,ym1,y0,yp1,yp2,yp3,a)=-a/60.*(-ym2+8.*ym1-37.*y0 1 -37.*yp1+8.*yp2-yp3) 2-a**2/360.*(-2.*ym2+25.*ym1-245.*y0+245.*yp1-25.*yp2+2.*yp3) 3-a**3/48.*(ym2-7.*ym1+6.*y0+6.*yp1-7.*yp2+yp3) 4-a**4/144.*(ym2-11.*ym1+28.*y0-28.*yp1+11.*yp2-yp3) 5-a**5/240.*(-ym2+3.*ym1-2.*y0-2.*yp1+3.*yp2-yp3) 6-a**6/720.*(-ym2+5.*ym1-10.*y0+10.*yp1-5.*yp2+yp3) pp(xi)=amax1(0.,xi) pn(xi)=amin1(0.,xi) c do 1 j=1,n2 do 1 i=1,np ig0(i,1,j)=nint(xd1(i,1,j)) 1 jg0(i,1,j)=nint(xd2(i,1,j)) c grid extension for bc removal do 509 j=1,n2 do 509 i=1,np 509 x(i,1,j)=xf(i,1,j) do 5091 is=1,ior do 5092 i=1,np x(i,1, 1-is)=(1-ibcz)*xf(i,1, 1)+ibcz*x(i,1,n2-is) 5092 x(i,1,n2+is)=(1-ibcz)*xf(i,1,n2)+ibcz*x(i,1, 1+is) 5091 continue #if (PARALLEL > 0) #if (POLES == 0) if(ibcx.eq.1) call updatelagr(x,np,mp,(n2+2*ior),np,mp,ior+1) if (leftedge.eq.1) then do 5071 j=-ior+1,n2+ior do is=-ior+1,1 x(is,1,j)=x(1,1,j)*(1-ibcx)+ibcx*x(is-ior-1,1,j) end do 5071 continue end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n2+2*ior),np,mp,ior+1) if (rightedge.eq.1) then do 5072 j=-ior+1,n2+ior do is=0,ior x(np+is,1,j)=x(np,1,j)*(1-ibcx)+ibcx*x(np+ior+1+is,1,j) end do 5072 continue end if #endif call updatelagr(x,np,mp,(n2+2*ior),np,mp,ihlag) #else #if (POLES == 0) do 507 is=0,ior do 5071 j=-ior+1,n2+ior x( 1-is,1,j)=x( 1,1,j)*(1-ibcx)+ibcx*x(np-is,1,j) 5071 x(np+is,1,j)=x(np,1,j)*(1-ibcx)+ibcx*x( 1+is,1,j) 507 continue #else do 507 is=0,ior do 5071 j=-ior+1,n2+ior x( 1-is,1,j)=x(np-is,1,j) 5071 x(np+is,1,j)=x( 1+is,1,j) 507 continue #endif #endif c end of grid extension c c c here starts rezidual advection c do 50 j=-ior,ior c if(liner.eq.1) then do 211 jj=1,n2 do 211 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) 211 z(ii,1,jj,j)=y0-(fl1-fl0) go to 50 endif c if(ior.eq.1) then if(nonos.eq.1) then do 311 jj=1,n2 do 311 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il if (jj.eq.n2 .and. ii.eq.np . .and. j.eq.ior) ifirst=0 end if ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 311 z(ii,1,jj,j)=w-(f1-f0) else do 321 jj=1,n2 do 321 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) 321 z(ii,1,jj,j)=y0-(f1-f0) endif endif c if(ior.eq.2) then il2=-ior ir2= ior if(nonos.eq.1) then do 312 jj=1,n2 do 312 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-2 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) #else ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 312 z(ii,1,jj,j)=w-(f1-f0) else do 322 jj=1,n2 do 322 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-2 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) #else ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) 322 z(ii,1,jj,j)=y0-(f1-f0) endif endif c if(ior.eq.3) then il3=-ior il2=-ior+1 il2= ior-1 il3= ior if(nonos.eq.1) then do 313 jj=1,n2 do 313 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-3 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir3)=il ym3=x(iloc(ii,1,jj,il3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,ir3),1,jg0(ii,1,jj)+j) #else ym3=x(ig0(ii,1,jj)-3,1,jg0(ii,1,jj)+j) ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) yp3=x(ig0(ii,1,jj)+3,1,jg0(ii,1,jj)+j) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 313 z(ii,1,jj,j)=w-(f1-f0) else do 323 jj=1,n2 do 323 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-3 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir3)=il ym3=x(iloc(ii,1,jj,il3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,ir3),1,jg0(ii,1,jj)+j) #else ym3=x(ig0(ii,1,jj)-3,1,jg0(ii,1,jj)+j) ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) yp3=x(ig0(ii,1,jj)+3,1,jg0(ii,1,jj)+j) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) 323 z(ii,1,jj,j)=y0-(f1-f0) endif endif c c 50 continue c if(liner.eq.1) then do 212 jj=1,n2 do 212 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) 212 xf(ii,1,jj)=z(ii,1,jj,0)-(fl1-fl0) call update(xf,np,mp,n2,np,mp,1) goto 500 endif c if(ior.eq.1) then if(nonos.eq.1) then do 411 jj=1,n2 do 411 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr2(z(ii,1,jj,-1),z(ii,1,jj,0),u) f1=tr2(z(ii,1,jj, 0),z(ii,1,jj,1),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 411 continue else do 421 jj=1,n2 do 421 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr2(z(ii,1,jj,-1),z(ii,1,jj,0),u) f1=tr2(z(ii,1,jj, 0),z(ii,1,jj,1),u) 421 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 412 jj=1,n2 do 412 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr4(z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),u) f1=tr4(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),z(ii,1,jj,ir2),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 412 continue else do 422 jj=1,n2 do 422 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr4(z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),u) f1=tr4(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),z(ii,1,jj,ir2),u) 422 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 413 jj=1,n2 do 413 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr6(z(ii,1,jj,il3),z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj,ir2),u) f1=tr6(z(ii,1,jj,il2),z(ii,1,jj, -1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj,ir2),z(ii,1,jj,ir3),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 413 continue else do 423 jj=1,n2 do 423 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr6(z(ii,1,jj,il3),z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj,ir2),u) f1=tr6(z(ii,1,jj,il2),z(ii,1,jj, -1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj,ir2),z(ii,1,jj,ir3),u) 423 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif 500 continue #if (POLES == 0) goto 999 cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(xf,np,mp,n2,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp xf(np,j,k)=xf(np+1,j,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np xf(i,j,l)=xf(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue #endif call update(xf,np,mp,n2,np,mp,1) return end #else subroutine inter3(xf,xd1,xd2,xd3,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' include 'param.nml' include 'msg.inc' parameter(nonos=1) parameter(n1=n,n2=m,n3=l,nn=n1*n2*n3) c NOTE: ihlag must be >= (ior + 1) dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l), . xd3(1-ih:np+ih,1-ih:mp+ih,l) dimension ig0(1-ih:np+ih,1-ih:mp+ih,l), . jg0(1-ih:np+ih,1-ih:mp+ih,l), . kg0(1-ih:np+ih,1-ih:mp+ih,l) dimension x(1-ior-ihlag:np+ior+ihlag, . 1-ior-ihlag:mp+ior+ihlag,1-ior:n3+ior) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(ixa=(np+2*ihlag+2*ior)*(mp+2*ihlag+2*ior)*(n3+2*ior)) parameter(ifree=16*iarray-2*(2*ior+1)*iarray) c parameter(ifree=16*iarray-2*(2*ior+1)*iarray-ixa) common/blank/ y(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . z(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . scr(ifree) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (PARALLEL>0) common /slag/ iloc(np,mp,n3,-ior:ior),jloc(np,mp,n3,-ior:ior) #endif common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) data ep/1.e-10/ real mx,mn donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 tr2(y1,y2,a)=a*.5*(y1+y2)-a**2*.5*(y2-y1) tr4(ym1,y0,yp1,yp2,a)=a/12.*(7.*(yp1+y0)-(yp2+ym1)) 1 -a**2/24.*(15.*(yp1-y0)-(yp2-ym1))-a**3/12.*((yp1+y0) 2 -(yp2+ym1))+a**4/24.*(3.*(yp1-y0)-(yp2-ym1)) tr6(ym2,ym1,y0,yp1,yp2,yp3,a)=-a/60.*(-ym2+8.*ym1-37.*y0 1 -37.*yp1+8.*yp2-yp3) 2-a**2/360.*(-2.*ym2+25.*ym1-245.*y0+245.*yp1-25.*yp2+2.*yp3) 3-a**3/48.*(ym2-7.*ym1+6.*y0+6.*yp1-7.*yp2+yp3) 4-a**4/144.*(ym2-11.*ym1+28.*y0-28.*yp1+11.*yp2-yp3) 5-a**5/240.*(-ym2+3.*ym1-2.*y0-2.*yp1+3.*yp2-yp3) 6-a**6/720.*(-ym2+5.*ym1-10.*y0+10.*yp1-5.*yp2+yp3) pp(xi)=amax1(0.,xi) pn(xi)=amin1(0.,xi) c do kk=1,l do jj=1,mp do ii=1,np ig0(ii,jj,kk)=nint(xd1(ii,jj,kk)) jg0(ii,jj,kk)=nint(xd2(ii,jj,kk)) kg0(ii,jj,kk)=nint(xd3(ii,jj,kk)) end do end do end do c c grid extension for bc removal do 507 k=1,n3 do 507 j=1,mp do 507 i=1,np 507 x(i,j,k)=xf(i,j,k) do 5071 is=1,ior do 5072 j=1,mp do 5072 i=1,np x(i,j, 1-is)=(1-ibcz)*xf(i,j, 1)+ibcz*x(i,j,n3-is) 5072 x(i,j,n3+is)=(1-ibcz)*xf(i,j,n3)+ibcz*x(i,j, 1+is) 5071 continue #if (PARALLEL > 0) #if (POLES == 0) if(ibcy.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (botedge.eq.1) then do is=1,ior do k=-ior+1,n3+ior do i=1,np x(i,1 -is,k)=x(i, 1,k)*(1-ibcy)+ibcy*x(i,(1-ior-is-1),k) end do end do end do end if if(ibcy.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (topedge.eq.1) then do is=1,ior do k=-ior+1,n3+ior do i=1,np x(i,mp+is,k)=x(i,mp,k)*(1-ibcy)+ibcy*x(i,mp+ior+1+is,k) end do end do end do end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (leftedge.eq.1) then jllim = 1 - ior*botedge julim = mp + ior*topedge do is=1,ior do k=-ior+1,n3+ior do j=jllim,julim x( 1-is,j,k)=x( 1,j,k)*(1-ibcx)+ibcx*x(1-ior-is-1,j,k) end do end do end do end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (rightedge.eq.1) then jllim = 1 - ior*botedge julim = mp + ior*topedge do is=1,ior do k=-ior+1,n3+ior do j=jllim,julim x(np+is,j,k)=x(np,j,k)*(1-ibcx)+ibcx*x(np+ior+1+is,j,k) end do end do end do end if #endif call updatelagr(x,np,mp,(n3+2*ior),np,mp,ihlag) #else #if (POLES == 0) do 508 is=1,ior do 5081 k=-ior+1,n3+ior do 5081 i=1,np x(i,1 -is,k)=x(i, 1,k)*(1-ibcy)+ibcy*x(i,mp-is,k) 5081 x(i,mp+is,k)=x(i,mp,k)*(1-ibcy)+ibcy*x(i, 1+is,k) 508 continue do 509 is=1,ior do 5091 k=-ior+1,n3+ior do 5091 j=-ior+1,mp+ior x( 1-is,j,k)=x( 1,j,k)*(1-ibcx)+ibcx*x(np-is,j,k) 5091 x(np+is,j,k)=x(np,j,k)*(1-ibcx)+ibcx*x( 1+is,j,k) 509 continue #else do 508 is=1,ior do 5081 k=-ior+1,n3+ior do 5081 i=1,np x(i,1 -is,k)=x(i,mp-is,k) 5081 x(i,mp+is,k)=x(i, 1+is,k) 508 continue do 509 is=1,ior do 5091 k=-ior+1,n3+ior do 5091 j=-ior+1,mp+ior x( 1-is,j,k)=x(np-is,j,k) 5091 x(np+is,j,k)=x( 1+is,j,k) 509 continue #endif #endif c c here starts rezidual advection c do 60 k=-ior,ior do 50 j=-ior,ior c if(liner.eq.1) then do 211 kk=1,n3 do 211 jj=1,mp do 211 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) 211 z(ii,jj,kk,j)=y0-(fl1-fl0) go to 50 endif c if(ior.eq.1) then if(nonos.eq.1) then do 3110 kk=1,n3 do 3110 jj=1,mp do 3110 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) if (ifirst.eq.1) then ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il end if y0 =x(iloc(ii,jj,kk,0),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il if (kk.eq.n3 .and. jj.eq.mp .and. ii.eq.np . .and. j.eq.ior) ifirst=0 end if yp1=x(iloc(ii,jj,kk,1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 3110 z(ii,jj,kk,j)=w-(f1-f0) else do 321 kk=1,n3 do 321 jj=1,mp do 321 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) 321 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c if(ior.eq.2) then il2=-ior ir2= ior if(nonos.eq.1) then do 312 kk=1,n3 do 312 jj=1,mp do 312 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-2 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) end if ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) #else ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 312 z(ii,jj,kk,j)=w-(f1-f0) else do 322 kk=1,n3 do 322 jj=1,mp do 322 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-2 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) end if ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) #else ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) 322 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c if(ior.eq.3) then il3=-ior il2=-ior+1 ir2= ior-1 ir3= ior if(nonos.eq.1) then do 313 kk=1,n3 do 313 jj=1,mp do 313 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-3 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il3)=il ! iloc(ii,jj,kk,-3) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir3)=il ! iloc(ii,jj,kk,3) end if ym3=x(iloc(ii,jj,kk,il3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-3) ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) yp3=x(iloc(ii,jj,kk,ir3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,3) #else ym3=x(ig0(ii,jj,kk)-3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp3=x(ig0(ii,jj,kk)+3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 313 z(ii,jj,kk,j)=w-(f1-f0) else do 323 kk=1,n3 do 323 jj=1,mp do 323 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-3 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il3)=il ! iloc(ii,jj,kk,-3) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir3)=il ! iloc(ii,jj,kk,3) end if ym3=x(iloc(ii,jj,kk,il3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-3) ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) yp3=x(iloc(ii,jj,kk,ir3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,3) #else ym3=x(ig0(ii,jj,kk)-3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp3=x(ig0(ii,jj,kk)+3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) 323 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c c 50 continue c if(liner.eq.1) then do 212 kk=1,n3 do 212 jj=1,mp do 212 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) 212 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(fl1-fl0) go to 60 endif c if(ior.eq.1) then if(nonos.eq.1) then do 411 kk=1,n3 do 411 jj=1,mp do 411 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr2(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) f1=tr2(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 411 continue else do 421 kk=1,n3 do 421 jj=1,mp do 421 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr2(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) f1=tr2(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) 421 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 412 kk=1,n3 do 412 jj=1,mp do 412 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr4(z(ii,jj,kk,il2),z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1), . u) f1=tr4(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),z(ii,jj,kk,ir2), . u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 412 continue else do 422 kk=1,n3 do 422 jj=1,mp do 422 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr4(z(ii,jj,kk,il2),z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1), . u) f1=tr4(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),z(ii,jj,kk,ir2), . u) 422 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 413 kk=1,n3 do 413 jj=1,mp do 413 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr6(z(ii,jj,kk,il3),z(ii,jj,kk,il2),z(ii,jj,kk, -1), . z(ii,jj,kk, 0),z(ii,jj,kk, 1),z(ii,jj,kk,ir2),u) f1=tr6(z(ii,jj,kk,il2),z(ii,jj,kk, -1),z(ii,jj,kk, 0), . z(ii,jj,kk, 1),z(ii,jj,kk,ir2),z(ii,jj,kk,ir3),u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 413 continue else do 423 kk=1,n3 do 423 jj=1,mp do 423 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr6(z(ii,jj,kk,il3),z(ii,jj,kk,il2),z(ii,jj,kk, -1), . z(ii,jj,kk, 0),z(ii,jj,kk, 1),z(ii,jj,kk,ir2),u) f1=tr6(z(ii,jj,kk,il2),z(ii,jj,kk, -1),z(ii,jj,kk, 0), . z(ii,jj,kk, 1),z(ii,jj,kk,ir2),z(ii,jj,kk,ir3),u) 423 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif 60 continue c c c if(liner.eq.1) then do 612 kk=1,n3 do 612 jj=1,mp do 612 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) 612 xf(ii,jj,kk)=y(ii,jj,kk,0)-(fl1-fl0) goto 500 endif c if(ior.eq.1) then if(nonos.eq.1) then do 711 kk=1,n3 do 711 jj=1,mp do 711 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr2(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) f1=tr2(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 711 continue else do 721 kk=1,n3 do 721 jj=1,mp do 721 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr2(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) f1=tr2(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) 721 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 712 kk=1,n3 do 712 jj=1,mp do 712 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr4(y(ii,jj,kk,il2),y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1), . u) f1=tr4(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),y(ii,jj,kk,ir2), . u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 712 continue else do 722 kk=1,n3 do 722 jj=1,mp do 722 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr4(y(ii,jj,kk,il2),y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1), . u) f1=tr4(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),y(ii,jj,kk,ir2), . u) 722 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 713 kk=1,n3 do 713 jj=1,mp do 713 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr6(y(ii,jj,kk,il3),y(ii,jj,kk,il2),y(ii,jj,kk, -1), . y(ii,jj,kk, 0),y(ii,jj,kk, 1),y(ii,jj,kk,ir2),u) f1=tr6(y(ii,jj,kk,il2),y(ii,jj,kk, -1),y(ii,jj,kk, 0), . y(ii,jj,kk, 1),y(ii,jj,kk,ir2),y(ii,jj,kk,ir3),u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 713 continue else do 723 kk=1,n3 do 723 jj=1,mp do 723 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr6(y(ii,jj,kk,il3),y(ii,jj,kk,il2),y(ii,jj,kk, -1), . y(ii,jj,kk, 0),y(ii,jj,kk, 1),y(ii,jj,kk,ir2),u) f1=tr6(y(ii,jj,kk,il2),y(ii,jj,kk, -1),y(ii,jj,kk, 0), . y(ii,jj,kk, 1),y(ii,jj,kk,ir2),y(ii,jj,kk,ir3),u) 723 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif c 500 continue #if (POLES == 0) cc goto 999 cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(xf,np,mp,n3,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp xf(np,j,k)=xf(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(xf,np,mp,n3,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np xf(i,mp,k)=xf(i,mp+1,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np xf(i,j,l)=xf(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue #endif call update(xf,np,mp,n3,np,mp,1) return end #endif subroutine traject(u,v,w,n1,m1,l1,gc1,gc2,gc3,itrt) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l,0:2), . v(1-ih:np+ih,1-ih:mp+ih,l,0:2), . w(1-ih:np+ih,1-ih:mp+ih,l,0:2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slt/ x0(1-ih:np+ih,1-ih:mp+ih,l), 1 y0(1-ih:np+ih,1-ih:mp+ih,l), 1 z0(1-ih:np+ih,1-ih:mp+ih,l), 1 upr(1-ih:np+ih,1-ih:mp+ih,l), 1 vpr(1-ih:np+ih,1-ih:mp+ih,l), 1 wpr(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) C return #if (TIMEPLT == 1) call ttbeg(37) #endif compute euler backward predictor xo=x-v(x,t1)*dt do 12 k=1,l do 12 j=1,mp do 12 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-gc1*u(i,j,k,1) y0(i,j,k)= ja-gc2*v(i,j,k,1) 12 z0(i,j,k)= k-gc3*w(i,j,k,1) call trajbc(x0,y0,z0) if(itraj.eq.0) then corrector xo=x-.5dt*(v(xo,to)+v(x1,t1)) for itraj=0 do 11 iter=1,itrt do 13 k=1,l do 13 j=1,mp do 13 i=1,np upr(i,j,k)=u(i,j,k,0) vpr(i,j,k)=v(i,j,k,0) 13 wpr(i,j,k)=w(i,j,k,0) call interp(upr,x0,y0,z0,1) if(j3.eq.1) call interp(vpr,x0,y0,z0,0) call interp(wpr,x0,y0,z0,0) do 14 k=1,l do 14 j=1,mp do 14 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-.5*gc1*(upr(i,j,k)+u(i,j,k,1)) y0(i,j,k)= ja-.5*gc2*(vpr(i,j,k)+v(i,j,k,1)) 14 z0(i,j,k)= k-.5*gc3*(wpr(i,j,k)+w(i,j,k,1)) call trajbc(x0,y0,z0) 11 continue else corrector xo=x-v(xo,to)*dt-dv/dt(xo,to)*.5*dt**2 for itraj=1 do 22 iter=1,itrt do 23 k=1,l do 23 j=1,mp do 23 i=1,np upr(i,j,k)=u(i,j,k,1) vpr(i,j,k)=v(i,j,k,1) 23 wpr(i,j,k)=w(i,j,k,1) call interp(upr,x0,y0,z0,1) if(j3.eq.1) call interp(vpr,x0,y0,z0,0) call interp(wpr,x0,y0,z0,0) do 24 k=1,l do 24 j=1,mp do 24 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-gc1*upr(i,j,k) y0(i,j,k)= ja-gc2*vpr(i,j,k) 24 z0(i,j,k)= k-gc3*wpr(i,j,k) call trajbc(x0,y0,z0) 22 continue endif #if (TIMEPLT == 1) call ttend(37) #endif return end subroutine trajbc(x0,y0,z0) include 'param.nml' include 'msg.inc' dimension x0(1-ih:np+ih,1-ih:mp+ih,l), . y0(1-ih:np+ih,1-ih:mp+ih,l), . z0(1-ih:np+ih,1-ih:mp+ih,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(38) #endif #if (POLES == 0) chose maximum displacement at the lateral (dl) and vertical (dv) boundaries clear case is box where dl=dv=0 dl=0.4999 dv=ibcz*dl if(ibcx.eq.0) then do k=1,l do j=1,mp do i=1,np x0(i,j,k)=amax1(1.-dl,amin1( float(n)+dl, x0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(x0(i,j,k).lt.float(1)-dl) x0(i,j,k)=x0(i,j,k)+float(n-1) if(x0(i,j,k).gt.float(n)+dl) x0(i,j,k)=x0(i,j,k)-float(n-1) enddo enddo enddo endif if(ibcy.eq.0) then do k=1,l do j=1,mp do i=1,np y0(i,j,k)=amax1(1.-dl,amin1( float(m)+dl, y0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(y0(i,j,k).lt.float(1)-dl) y0(i,j,k)=y0(i,j,k)+float(m-j3) if(y0(i,j,k).gt.float(m)+dl) y0(i,j,k)=y0(i,j,k)-float(m-j3) enddo enddo enddo endif if(ibcz.eq.0) then do k=1,l do j=1,mp do i=1,np z0(i,j,k)=amax1(1.-dv,amin1( float(l)+dv, z0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(z0(i,j,k).lt.float(1)-dv) z0(i,j,k)=z0(i,j,k)+float(l-1) if(z0(i,j,k).gt.float(l)+dv) z0(i,j,k)=z0(i,j,k)-float(l-1) enddo enddo enddo endif #else cori xmap(xin, xlen) = amod(xin+xlen*20.-1., xlen)+1. c xmap(xx,t) = amod(xx+t*40.-1.,t)+1. nml=n*m*l ym=float(m)+.5 y1=0.5 ym2=2.*ym y12=2.*y1 xpr=float(n) xprh=float(n)*.5 dl=0.4999 do k=1,l do j=1,mp do i=1,np z0(i,j,k)=amax1(1.,amin1( float(l), z0(i,j,k) )) if(y0(i,j,k).gt.ym) then C---> Y = YM-(Y-YM) = 2*YM-Y y0(i,j,k)=ym2-y0(i,j,k) x0(i,j,k)=x0(i,j,k)+xprh endif if(y0(i,j,k).lt.y1) then C---> Y = Y1-(Y-Y1) = 2*Y1-Y y0(i,j,k)=y12-y0(i,j,k) x0(i,j,k)=x0(i,j,k)+xprh endif if(x0(i,j,k).lt.float(1)-dl) x0(i,j,k)=x0(i,j,k)+float(n) if(x0(i,j,k).gt.float(n)+dl) x0(i,j,k)=x0(i,j,k)-float(n) c x0(i,j,k)=xmap(x0(i,j,k),xpr) enddo enddo #endif #if (TIMEPLT == 1) call ttend(38) #endif return end #if (PARALLEL>0) subroutine lagrmsg(ia,ja,i,j) include 'param.nml' include 'param.ior' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c print *,'lagrmsg',mype #if (POLES == 0) if (leftedge.eq.0 .and. rightedge.eq.0) then i=ia-(npos-1)*np if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) then write(*,*)'***ia,i,npos,np,ihlag=',ia,i,npos,np,ihlag stop 211 end if else if (leftedge.eq.1 .and. rightedge.eq.0) then if (ia.le.np+ihlag) then i=ia if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) stop 211 else if (ia.gt.(n-ihlag) .and. ia.le.n) then i=-ior-n+ia else if (ia.gt.n .and. ia.le.(n+ior)) then if (ibcx.eq.0) then i=-ior else i=(ia-n)+1 end if else write(*,*)'***about to stop' stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.0) then if (ia.ge.(1+(npos-1)*np)-ihlag) then i=ia-(npos-1)*np else if (ia.ge.1 .and. ia.lt.(1+ihlag)) then i=np+ior+ia else if (ia.lt.1 .and. ia.ge.(1-ior)) then if (ibcx.eq.0) then i=np+ior+1 else i=np+ia-1 end if else stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.1) then i=ia end if if (topedge.eq.0 .and. botedge.eq.0) then j=ja-(mpos-1)*mp if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (botedge.eq.1 .and. topedge.eq.0) then if (ja.le.mp+ihlag) then j=ja if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (ja.gt.(m-ihlag) .and. ja.le.m) then j=-ior-m+ia else if (ja.gt.m .and. ja.le.(m+ior)) then if (ibcy.eq.0) then j=-ior else j=(ja-m)+1 end if else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.0) then if (ja.ge.(1+(mpos-1)*mp)-ihlag) then j=ja-(mpos-1)*mp else if (ja.ge.1 .and. ja.lt.(1+ihlag)) then j=mp+ior+ja else if (ja.lt.1 .and. ja.gt.(1-ior)) then if (ibcy.eq.0) then j=mp+ior+1 else j=mp+ia-1 end if else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.1) then j=ja end if #else if (leftedge.eq.0 .and. rightedge.eq.0) then i=ia-(npos-1)*np if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) then write(*,*)'***ia,i,npos,np,ihlag=',ia,i,npos,np,ihlag stop 211 end if else if (leftedge.eq.1 .and. rightedge.eq.0) then if (ia.le.np+ihlag) then i=ia if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) stop 211 else if (ia.gt.(n-ihlag) .and. ia.le.n) then i=-ior-n+ia else if (ia.gt.n .and. ia.le.(n+ior)) then i=(ia-n)+1 else write(*,*)'***about to stop' stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.0) then if (ia.ge.(1+(npos-1)*np)-ihlag) then i=ia-(npos-1)*np else if (ia.ge.1 .and. ia.lt.(1+ihlag)) then i=np+ior+ia else if (ia.lt.1 .and. ia.ge.(1-ior)) then i=np+ia-1 else stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.1) then i=ia end if if (topedge.eq.0 .and. botedge.eq.0) then j=ja-(mpos-1)*mp if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (botedge.eq.1 .and. topedge.eq.0) then if (ja.le.mp+ihlag) then j=ja if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (ja.gt.(m-ihlag) .and. ja.le.m) then j=-ior-m+ia else if (ja.gt.m .and. ja.le.(m+ior)) then j=(ja-m)+1 else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.0) then if (ja.ge.(1+(mpos-1)*mp)-ihlag) then j=ja-(mpos-1)*mp else if (ja.ge.1 .and. ja.lt.(1+ihlag)) then j=mp+ior+ja else if (ja.lt.1 .and. ja.gt.(1-ior)) then j=mp+ia-1 else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.1) then j=ja end if #endif c print *,'lagrmsg done',mype return end #endif /* J3DIM */ #endif /* SEMILAG == 1 */ #endif /* ANALIZE == 0 */ subroutine cndinst include 'param.nml' include 'msg.inc' common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) #if (TIMEPLT == 1) call ttbeg(52) #endif c=hlat/cp x0=-1.e15 do 1 k=1,l thetme=the(1,1,k)/tme(1,1,k) x=the(1,1,k)+c*thetme*qve(1,1,k) index=1 if(x.le.x0) index=-1 x0=x if (mype.eq.0) then if(index.eq.-1) print 100, x,k,index 100 format(2x,'thetae, k, index:', e11.4, 2i4) end if 1 continue #if (TIMEPLT == 1) call ttend(52) #endif return end #if (MOISTMOD > 0) subroutine cond(th,qv,qc,qr,fth,fqv,fqc,fqr,tau) include 'param.nml' include 'msg.inc' dimension th(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fth(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) dimension tau(l,1-ih:np+ih,1-ih:mp+ih) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/temp_p/ tup,tdn common/latent/hlatv,hlats common/znave/ uza(mp,l),vza(mp,l),wza(mp,l),thza(mp,l), . qvza(mmsp,lms),bxza(mmhdp,lmhd),byza(mmhdp,lmhd), . byza(mmhdp,lmhd) 1 dxabL,dxabR,dyab,iab,iabth,iabqw alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad #if (TIMEPLT == 1) call ttbeg(53) #endif condensation/evaporation IF(ICE.EQ.1) THEN a=rg/rv b=hlats/rv d=hlatv/rv c=hlatv/cp e=-cp/rg do k=1,l do j=1,mp do i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e tt=th(i,j,k)/thetme c coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution coe_l=comb( tt ,tdn,tup,0.,1.) ! liquid contribution delt=(tt-t00)/(tt*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) qvs=coe_l*qvsw + (1.-coe_l)*qvsi ccc linearized condensation rate is next: cf1=thetme/th(i,j,k) cf1=cf1*cf1 cf1=c*cf1*pre/(pre-esw)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) ccc one Newton-Raphson iteration is next: thn=th(i,j,k)+c*thetme*delta tt=thn/thetme delt=(tt-t00)/(tt*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) qvs=coe_l*qvsw + (1.-coe_l)*qvsi fff=qv(i,j,k)-delta-qvs cf1=1./tt cf1=cf1*cf1 cf1=c*cf1*pre/(pre-esw)*d fffp=-1.-qvs*cf1 delta=delta-fff/fffp ccc end of the iteration; if required, it can be repeated by copying ccc the piece of code above (no inner loop for vectorization reason) c---> delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) qv(i,j,k)=qv(i,j,k)-delta qc(i,j,k)=qc(i,j,k)+delta th(i,j,k)=th(i,j,k)+c*thetme*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fqc(i,j,k)=-fqv(i,j,k) fth(i,j,k)=c*thetme*fqc(i,j,k) enddo enddo enddo ELSE a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do k=1,l do j=1,mp do i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e thi=1./th(i,j,k) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ccc linearized condensation rate: cf1=thetme*thetme*thi*thi cf1=c*cf1*pre/(pre-ees)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) ccc one Newton-Raphson iteration is next: thi=1./(th(i,j,k)+c*thetme*delta) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) fff=qv(i,j,k)-delta-qvs cf1=thetme*thetme*thi*thi cf1=c*cf1*pre/(pre-ees)*d fffp=-1.-qvs*cf1 delta=delta-fff/fffp ccc end of the iteration; if required, it can be repeated by copying ccc the piece of code above (no inner loop for vectorization reason) c---> delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) qv(i,j,k)=qv(i,j,k)-delta qc(i,j,k)=qc(i,j,k)+delta th(i,j,k)=th(i,j,k)+c*thetme*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fqc(i,j,k)=-fqv(i,j,k) fth(i,j,k)=c*thetme*fqc(i,j,k) enddo enddo enddo ENDIF compute gravity wave absorber (implicit) dth=0.5*dt do 20 k=1,l do 20 j=1,mp do 20 i=1,np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) tth=tau(k,i,j)*(1.-relt)+relt tqv=tth*iabqw th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dth)/(1.+tth*dth) qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dth)/(1.+tqv*dth) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+tqv*dth) qr(i,j,k)=(qr(i,j,k)+ 0. )/(1.+tqv*dth) fqv(i,j,k)=fqv(i,j,k)-tqv*( qv(i,j,k)-qve(i,j,k)) c---------> special, absorbing to zonal averages c th(i,j,k)=th(i,j,k)-tth*(the(i,j,k)-thza(j,k))*dth/(1.+tth*dth) c qv(i,j,k)=qv(i,j,k)-tqv*(qve(i,j,k)-qvza(j,k))*dth/(1.+tqv*dth) c fqv(i,j,k)=fqv(i,j,k)-tqv*(qve(i,j,k)-qvza(j,k)) c---------> end of special fqc(i,j,k)=fqc(i,j,k)-tqv*(qc(i,j,k)-0.) fqr(i,j,k)= -tqv*(qr(i,j,k)-0.) 20 continue #if (TIMEPLT == 1) call ttend(53) #endif return end subroutine adj_prec(thf,qv,qc,qr,ftf,fqv,fqc,fqr, . ftfa,fqva,fqca,fqra,n1,m1,l1) include 'param.nml' include 'msg.inc' dimension thf(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftf(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftfa(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqva(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqca(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqra(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/latent/hlatv,hlats #if (TIMEPLT == 1) call ttbeg(54) #endif dth=.5*dt do k=1,l do j=1,mp do i=1,np cc field + .5 condensation at the departure point: thf(i,j,k)=thf(i,j,k) + ftf(i,j,k)*dth qv(i,j,k) = qv(i,j,k) + fqv(i,j,k)*dth qc(i,j,k) = qc(i,j,k) + fqc(i,j,k)*dth qr(i,j,k) = qr(i,j,k) + fqr(i,j,k)*dth cc ccc final adjustment and application of forces due to rain: fqc2 = amax1(fqca(i,j,k), -qc(i,j,k)*dti ) fqr2 = amax1(fqra(i,j,k), -qr(i,j,k)*dti ) delql=fqc2-fqca(i,j,k)+fqr2-fqra(i,j,k) cc adjust force for qv to conserve water: fqv2=fqva(i,j,k)-delql cc adjust force for th to conserve energy: ftf2=ftfa(i,j,k) + the(i,j,k)/tme(i,j,k)*hlatv/cp*delql thf(i,j,k)=thf(i,j,k) + ftf2*dt qv(i,j,k)= amax1(0., qv(i,j,k) + fqv2*dt) qc(i,j,k)= amax1(0., qc(i,j,k) + fqc2*dt) qr(i,j,k)= amax1(0., qr(i,j,k) + fqr2*dt) ftfa(i,j,k) = ftf2 enddo enddo enddo #if (TIMEPLT == 1) call ttend(54) #endif return end subroutine micro_init common/rain_p1/ dconc,ddisp if(dconc.gt.2000. .or. dconc.lt.50.) stop 'MICRO' cc relative dispersion for Berry's autoconversion: ddisp=0.146-5.964e-2*alog(dconc/2000.) return end subroutine precip(th,qv,qc,qr,fth,fqv,fqc,fqr, 1 n1,m1,l1,ndtm,dtm,itst) include 'param.nml' include 'msg.inc' dimension th(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fth(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/rain/ rac,qctr,rc common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common /water_bgdt/ totw0,totw(nth),prec(nth),sflux(nth), 1 prec_dis(np,mp) common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/rain_p1/ dconc,ddisp common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn common/latent/hlatv,hlats real lambdr,lambds,massr,masss real globsum common/blank/ rhl(1-ih:np+ih, 1-ih:mp+ih, l), . thetme(1-ih:np+ih, 1-ih:mp+ih, l), . scr14(1-ih:np+ih, 1-ih:mp+ih, l, 14) dimension ss(l),gac(l),den(l),th1(l),qv1(l),qc1(l),qr1(l), 1 fth1(l),fqv1(l),fqc1(l),fqr1(l),qr2(l),tt1(l),vterm(l+1) alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad #if (TIMEPLT == 1) call ttbeg(55) #endif dtmi=1./dtm iulim=rightedge*(np-1)+(1-rightedge)*np pi=3.14159 IF(ICE.EQ.1) THEN a=rg/rv b=hlats/rv c=hlatv/cp d=hlatv/rv e=-cp/rg ELSE a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg ENDIF do 10 k=1,l do 10 j=1,mp do 10 i=1,np dnm=stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j) rhl(i,j,k)=rho(i,j,k)*(gi(i,j)*gmus(k)) + /((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnm thetme(i,j,k)=the(i,j,k)/tme(i,j,k) 10 continue tot_prec=0. do 77 j=1,mp do 77 i=1,np prec_ij=0. cc check if there is/will be a trace of condensate in a column: qmx=0. do k=1,l qtot=qc(i,j,k)+qr(i,j,k) qmx=amax1(qmx,qtot) qmx=amax1(qmx,qtot+dt*(fqc(i,j,k)+fqr(i,j,k))) enddo if(qmx.lt.1.e-8) then cc NO ADJUSTEMENT REQUIRED, just convert the trace into vapor: do k=1,l fqc(i,j,k)=-qc(i,j,k)*dti fqr(i,j,k)=-qr(i,j,k)*dti fqv(i,j,k)=(qc(i,j,k)+qr(i,j,k))*dti fth(i,j,k)=-c*thetme(i,j,k)*(qc(i,j,k)+qr(i,j,k))*dti enddo else cc ADJUSTEMENT REQUIRED cc initial conditions: do k=1,l gac(k)=rho(i,j,k) den(k)=rhl(i,j,k) th1(k)=th(i,j,k) qv1(k)=qv(i,j,k) qc1(k)=qc(i,j,k) qr1(k)=qr(i,j,k) fth1(k)=0. fqv1(k)=0. fqc1(k)=0. fqr1(k)=0. enddo cc forward in time with a small time step: do iter=1,ndtm cc sources of precipitation: IF(ICE.EQ.1) THEN do k=1,l tti=th1(k)/thetme(i,j,k) pre=1.e5*thetme(i,j,k)**e c coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution coe_l=comb( tti ,tdn,tup,0.,1.) ! liquid contribution delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) ssw=qv1(k) / qvsw ! saturation ratio ssi=qv1(k) / qvsi ! saturation ratio qpr=qr1(k)*coe_l ! divide between rain and snow qps=qr1(k)-qpr ! divide between rain and snow qcc=qc1(k)*coe_l ! divide between ice and water qci=qc1(k)-qcc ! divide between ice and water lambdr=(ar*anor*gamb1r/rhl(i,j,k) / 1 amax1(qpr,1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/rhl(i,j,k) / 1 amax1(qps,1.e-6))**(1./(1.+bs)) ! lambda CC AUTOCONVERSION: cc rain - Berry: del2=1.e3*rhl(i,j,k)*qcc autc=1./rhl(i,j,k)*1.67e-5*del2*del2 / 1 (5. + .0366*dconc/(ddisp*(del2+1.E-6))) cc snow: tc=tti-273.16 times=amin1(1.e3,(3.56*tc+106.7)*tc+1.e3) ! time scale for auti=qci/times AUT = autc + auti CC GROWTH: conr=anor/lambdr ! concentration cons=anos/lambds ! concentration massr=rhl(i,j,k)*amax1(qpr,1.e-7) / conr ! mass masss=rhl(i,j,k)*amax1(qps,1.e-7) / cons ! mass diamr=(massr/ar)**(1./br) ! diameter diams=(masss/as)**(1./bs) ! diameter rer=cr*diamr**(dr+1.)/2.e-5 ! Reynolds number res=cs*diams**(ds+1.)/2.e-5 ! Reynolds number ventr=amax1(1.,.78+.27*sqrt(rer)) ! ventilation factor vents=amax1(1.,.65+.39*sqrt(res)) ! ventilation factor thfun=1.e-7/(2.2*tme(i,j,k)/esw+2.2e2/tme(i,j,k)) ! thermodynamic fun. g_acc_r=pi/4.*cr*diamr**(2.+dr)*er*alphr*rhl(i,j,k)*qc(i,j,k) ! growth g_acc_s=pi/4.*cs*diams**(2.+ds)*es*alphs*rhl(i,j,k)*qc(i,j,k) ! growth g_dep_r=4.*pi*diamr/betr*(ssw-1.)*ventr*thfun ! growth/evap g_dep_s=4.*pi*diams/bets*(ssi-1.)*vents*thfun ! growth/evap acc_r=conr * g_acc_r * qpr / (qpr + 1.e-9) acc_s=cons * g_acc_s * qps / (qps + 1.e-9) ACC= acc_r + acc_s ! growth by accretion dep_r=conr * g_dep_r * qpr / (qpr + 1.e-9) dep_s=cons * g_dep_s * qps / (qps + 1.e-9) DEP= dep_r + dep_s ! growth by deposition ccc with precip... dcol=amin1(AUT + ACC, dtmi*qc1(k)+fqc(i,j,k)) devp=amax1(DEP, -dtmi*qr1(k)-fqr(i,j,k)-dcol) ccc without precip... c dcol=0. c devp=0. c qv1(k)=qv1(k) + dtm*fqv(i,j,k) - dtm*devp qc1(k)=qc1(k) + dtm*fqc(i,j,k) - dtm*dcol qr1(k)=qr1(k) + dtm*fqr(i,j,k) + dtm*(devp+dcol) th1(k)=th1(k) + dtm*fth(i,j,k) + dtm*c*devp*thetme(i,j,k) fqv1(k)=fqv1(k)-devp fqc1(k)=fqc1(k)-dcol fqr1(k)=fqr1(k)+devp+dcol fth1(k)=fth1(k)+c*devp*thetme(i,j,k) c tt1(k)=tme(i,j,k) tt1(k)=tti qr2(k)=qr1(k) enddo ELSE do k=1,l pre=1.e5*thetme(i,j,k)**e thi=1./th1(k) y=b*thetme(i,j,k)*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ss(k)=amin1(qv1(k)/qvs-1., 0.) dcol= rac*amax1(qc1(k)-qctr, 0.) . + rc*qc1(k)*amax1(0.,qr1(k))**.875 dcol=amin1(dcol, dtmi*qc1(k)+fqc(i,j,k)) presmb=rhl(i,j,k)*rg*tme(i,j,k)/100. rhqr=rhl(i,j,k)*1.e-3*amax1(0.,qr1(k)) rhqr=amax1(rhqr,1.e-20) qvs=qv1(k)/(1.+ss(k)) bottom=1.e-3*rhl(i,j,k)*(5.4e5 + 2.55e6/(presmb*qvs)) ventc=1.6+124.9*rhqr**.2046 devp=ss(k)*ventc*rhqr**.525 / bottom devp=amax1(devp, -dtmi*qr1(k)-fqr(i,j,k)-dcol) c qv1(k)=qv1(k) + dtm*fqv(i,j,k) - dtm*devp qc1(k)=qc1(k) + dtm*fqc(i,j,k) - dtm*dcol qr1(k)=qr1(k) + dtm*fqr(i,j,k) + dtm*(devp+dcol) th1(k)=th1(k) + dtm*fth(i,j,k) + dtm*c*devp*thetme(i,j,k) fqv1(k)=fqv1(k)-devp fqc1(k)=fqc1(k)-dcol fqr1(k)=fqr1(k)+devp+dcol fth1(k)=fth1(k)+c*devp*thetme(i,j,k) c tt1(k)=tme(i,j,k) tt1(k)=th1(k)/thetme(i,j,k) qr2(k)=qr1(k) enddo ENDIF cc sedimentation: call rain_fall_clmn(qr2,tt1,den,vterm,l) call advec1d(l,dtm,dz,qr2,vterm,gac) if(i.lt.iulim) then cc precipitation deduced from change of rain water: prec_ij=prec_ij + .5*(qr1(1)-qr2(1))*rho(i,j,1) + 1 .5*(qr1(l)-qr2(l))*rho(i,j,l) do k=2,l-1 prec_ij=prec_ij+(qr1(k)-qr2(k))*rho(i,j,k) enddo endif do k=1,l fqr1(k)=fqr1(k)+(qr2(k)-qr1(k))*dtmi qr1(k)=qr2(k) enddo enddo cc prec_ij is the total qr change in a column prec_ij=prec_ij*dx*dy*dz cc prec_dis is converted in precipitation rate in kg/m**2/s prec_dis(i,j)=prec_dis(i,j) + prec_ij*dti/(dx*dy) cc get final force due to precip processes: do k=1,l fqv(i,j,k)=fqv1(k)/float(ndtm) fqc(i,j,k)=fqc1(k)/float(ndtm) fqr(i,j,k)=fqr1(k)/float(ndtm) fth(i,j,k)=fth1(k)/float(ndtm) enddo endif if(i.lt.iulim) tot_prec=tot_prec+prec_ij*dti 77 continue #if (PARALLEL > 0) temp=tot_prec tot_prec=globsum(temp,1,1,1,1,1,1,1,1,1,1,1,1) #endif prec(itst)=tot_prec c if (mype.eq.0) print*,' === it,precip: ',itst,prec(itst)/dti #if (TIMEPLT == 1) call ttend(55) #endif return end subroutine rain_fall_clmn(qr,temp,rho,uza,nz) include 'param.nml' include 'msg.inc' dimension qr(nz),temp(nz),uza(nz+1),rho(nz) common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn real lambdr,lambds alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad vtrmv(qq,rro)=36.34*sqrt(1./rro)*(rro*1.e-3*qq)**.1346 #if (TIMEPLT == 1) call ttbeg(56) #endif IF(ICE.EQ.1) THEN do k=2,nz dens= 0.5*(rho(k)+rho(k-1)) qrv = 0.5*( qr(k)+ qr(k-1)+1.e-10) coe_l=comb(temp(k),tdn,tup,0.,1.) ! liquid part qpr=qrv*coe_l ! divide between rain and snow qps=qrv-qpr ! divide between rain and snow lambdr=(ar*anor*gamb1r/dens/(qpr+1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/dens/(qps+1.e-6))**(1./(1.+bs)) ! lambda vtr=cr*gambd1r/gamb1r / lambdr**dr ! terminal velocity vts=cs*gambd1s/gamb1s / lambds**ds ! terminal velocity vtf=coe_l*vtr+(1.-coe_l)*vts ! TERMINAL VELOCITY uza(k)=-vtf*dens end do uza(1)=uza(2) uza(nz+1)=0. ELSE do k=2,nz dens= 0.5*(rho(k)+rho(k-1)) qrv = 0.5*( qr(k)+ qr(k-1)+1.e-10) vtr=vtrmv(qrv,dens) uza(k)=-vtr*dens end do uza(1)=uza(2) uza(nz+1)=0. ENDIF #if (TIMEPLT == 1) call ttend(56) #endif return end subroutine advec1d(nn,dt,dz,xs,om,rh) cc 1D advection modified for rain sedimentation in model column dimension xs(nn),om(nn+1),rh(nn) include 'param.nml' include 'msg.inc' parameter(n1=l+1) dimension fh(n1),vdz(n1),xmx(n1),xmn(n1),fpl(n1),fng(n1) donor(y1,y2,w,d)=0.5*dt/d*((w-abs(w))*y2+(w+abs(w))*y1) vdyf(x1,x2,w,d)=(-w**2*dt+abs(w)*d)/d*(x2-x1)/(x2+x1+eps) pp(x)=amax1(0.,x) pn(x)=amin1(0.,x) C #if (TIMEPLT == 1) call ttbeg(57) #endif impli=1 iord=1 nonos=0 eps=1.E-15 IF(IMPLI.EQ.1) THEN do iz=1,nn+1 vdz(iz)=om(iz)*dt/dz enddo xs(nn)=xs(nn)/(1.-vdz(nn)/rh(nn)) do iz=nn-1,1,-1 xs(iz)=(xs(iz)-vdz(iz+1)*xs(iz+1)/rh(iz))/(1.-vdz(iz)/rh(iz)) enddo ELSE do 1 iz=1,nn+1 vdz(iz)=om(iz) 1 continue if(nonos.eq.1) then do 400 iz=2,nn-1 xmx(iz)=amax1(xs(iz-1),xs(iz),xs(iz+1)) 400 xmn(iz)=amin1(xs(iz-1),xs(iz),xs(iz+1)) endif do 3 k=1,iord do 331 iz=2,nn fh(iz)=donor(xs(iz-1),xs(iz),vdz(iz),dz) 331 continue fh(1)=donor(0.,xs(1),vdz(1),dz) fh(nn+1)=0. do 333 iz=1,nn xs(iz)=xs(iz)-(fh(iz+1)-fh(iz))/rh(iz) 333 continue if(k.eq.iord) go to 6 do 51 iz=2,nn vdz(iz)=vdyf(xs(iz-1),xs(iz),vdz(iz),dz) 51 continue vdz(1)=0. vdz(nn+1)=0. if(nonos.eq.0) go to 3 do 401 iz=2,nn-1 xmx(iz)=amax1(xmx(iz),xs(iz-1),xs(iz),xs(iz+1)) 401 xmn(iz)=amin1(xmn(iz),xs(iz-1),xs(iz),xs(iz+1)) do 52 iz=2,nn fh(iz)=donor(xs(iz-1),xs(iz),vdz(iz),dz) 52 continue do 53 iz=2,nn-1 fpl(iz)=(xmx(iz)-xs(iz))/(-pn(fh(iz+1))+pp(fh(iz))+eps) fng(iz)=(xs(iz)-xmn(iz))/( pp(fh(iz+1))-pn(fh(iz))+eps) fpl(iz)=amax1(0.,amin1(1.,fpl(iz))) fng(iz)=amax1(0.,amin1(1.,fng(iz))) 53 continue fpl(1)=1. fpl(nn)=1. fng(1)=1. fng(nn)=1. do 54 iz=2,nn vdz(iz)=pp(vdz(iz))*amin1(fpl(iz),fng(iz-1)) 1 +pn(vdz(iz))*amin1(fpl(iz-1),fng(iz)) 54 continue vdz(1)=0. vdz(nn+1)=0. 3 continue 6 continue ENDIF #if (TIMEPLT == 1) call ttend(57) #endif return end #endif /* MOISTMOD > 0 */ subroutine rhfld(th,qv,rhf,n1,m1,l1,ipr) include 'param.nml' include 'msg.inc' dimension rhf(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat real globmax,globmin #if (TIMEPLT == 1) call ttbeg(58) #endif rhmx=-1.e15 rhmn= 1.e15 a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do 1 k=1,l do 1 j=1,mp do 1 i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e thi=1./(th(i,j,k)+the(i,j,k)) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) 1 rhf(i,j,k)=qv(i,j,k)/qvs rhmx=globmax(rhf,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) rhmn=globmin(rhf,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if (mype.eq.0) then if(ipr.eq.1) print 301,rhmx,rhmn 301 format(1x,'rhmx, rhmn:',2e11.4) endif #if (TIMEPLT == 1) call ttend(58) #endif return end subroutine header(lipps) include 'param.nml' include 'msg.inc' include 'param.ior' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gora/ xml,yml,amp,xml0,yml0,angle common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/stresd/ diagstr(8),ivis,irid,itstr character*80 title c ---- computational parameters write (6,999) write (6,8992) if(isphere.eq.1) then write (6,9000) (-90.+(m-0.5)*180./float(m)),rds/1000. end if write (6,901) n,m,L,lagr,ior write (6,914) nprocx,nprocy write (6,902) dx,dy,dz,dt write (6,903) nt,nplot,nstore write (6,904) ibcx,ibcy,ibcz,irlx,irly,irdbc write (6,905) iab,iabth,iabqw write (6,906) zab,towz if(isphere.eq.1) then write (6,908) towxL,towxR,towy,dxabL/(rds*3.1416)*180. . ,dxabR/(rds*3.1416)*180. . ,dyab /(rds*3.1416)*180. else write (6,9080) towxL,towxR,towy,dxabL/1000. . ,dxabR/1000. . ,dyab/1000. end if c ---- basic state write (6,999) write (6,8994) eps=1.e-15 if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then write (6,929) u00,v00 else write (6,909) u00,u0z endif bv=sqrt(st*g) write (6,910) bv,lipps if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then ri00=0. write (6,899) write (title,899) else ri00 = g*st/(u0z**2 + v0z**2) write (6,900) ri00 endif c ---- physical parameters write (6,999) write (6,8996) write (6,912) icorio,ivis,itkes write (6,913) moist,ice c ---- transformation parameters write (6,999) write (6,8998) write (6,911) xml,yml,amp c write (6,9031) time,tt,tend 899 format(1x,'Ri0 = infinity') 8992 format(11x,'COMPUTATIONAL PARAMETERS') 8994 format(11x,'BASIC STATE') 8996 format(11x,'PHYSICAL PARAMETERS') 8998 format(11x,'TRANSFORMATION PARAMETERS') 900 format(1x,'Ri0 =',e11.4) 9000 format(1x,'SPHERE: meridional grid = +/-',f8.3,' degrees'/ . 11x,'radius = ',f8.1,' kms') 901 format(1x,'n,m,l =',3i5,5x,'lagr,ior =',2i5) 902 format(1x,'dx,dy,dz,dt =',4e11.4) 903 format(1x,'nt,nplot,nstore =',3i5) 9031 format(1x,'time,tt,tend =',3e11.4) 904 format(1x,'ibcx,ibcy,ibcz =',3i5/ . 1x,'irlx,irly,irdbc =',3i5) 905 format(1x,'iab,iabth,iabqw =',3i5) 906 format(1x,'zab,towz =',2e11.4) 908 format(1x,'towxL,towxR,towy =',3e11.4/ . 1x,'dxabL,dxabR,dyab =',3f5.2,' deg') 9080 format(1x,'towxL,towxR,towy =',3e11.4/ . 1x,'dxabL,dxabR,dyab =',3e11.4,' kms') 909 format(1x,'Const shear profile:'/ . 1x,' U00,U00Z =',2e11.4) 929 format(1x,'Const wind profile:'/ . 1x,' U00,V00 =',2e11.4) 910 format(1x,'Const stability profile:'/ . 1x,' N =',1x,e11.4,' lipps =',i3) 911 format(1x,'mountain scales:'/ . 1x,' Lx,Ly,h0 =',3e11.4) 912 format(1x,'icorio,ivis,itke =',3i5) 913 format(1x,'moist,ice =',2i5) 914 format(1x,'npr_x,npr_y =',2i5) 999 format(1x,' ****************** ') write (6,999) return end subroutine drag(p,fx,fy,n1,m1,l1) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih,1-ih:mp+ih,l),fx(nth),fy(nth) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/indx/ e1,e2,e3 #if (ANALIZE == 0) common/blank/ scr14(1-ih:np+ih, 1-ih:mp+ih, l, 14), . pe(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 7), . pe(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif real globsum #if (TIMEPLT == 1) call ttbeg(62) #endif dxil=.5*dxi dyil=.5*dyi do k=1,l do j=1,mp do i=1,np pe(i,j,k)=p(i,j,k) enddo enddo enddo fx(itd)=0. fy(itd)=0. illim=1 + leftedge iulim=np - rightedge jllim=1 + j3*botedge julim=mp - j3*topedge if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc calculate perturbation pressure do j=1,mp do i=1,np pe(i,j,1)=pe(i,j,1)*rho(i,j,1)*gi(i,j)*2.*dti enddo enddo do j=jllim,julim do i=illim,iulim temp(i,j,1)=(zs(i+1,j)-zs(i-1,j))*pe(i,j,1)*dxil end do end do fx(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,iulim,jllim,julim,1,1) if (j3.eq.1) then do j=jllim,julim do i=illim,iulim temp(i,j,1)=(zs(i,j+j3)-zs(i,j-j3))*pe(i,j,1)*dyil end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,iulim,jllim,julim,1,1) end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc calculate perturbation pressure construct perturbation pressure along the lower boundary for igrid=1 do j=jllim,mp do i=illim,np plex =e1*pe(i,j,2)+e2*pe(i,j,3)+e3*pe(i,j,4) rhoav=( rho(i-1,j-j3,1)*gi(i-1,j-j3) 1 + rho(i,j-j3,1)*gi(i,j-j3) 1 + rho(i-1,j,1)*gi(i-1,j) 1 + rho(i,j,1)*gi(i,j) )*0.25 pe(i,j,1)=plex*rhoav*2.*dti enddo enddo do j=jllim,mp do i=illim,np temp(i,j,1)=(pe(i,j,1)*dxil* * (zs(i,j)-zs(i-1,j)+zs(i,j-j3)-zs(i-1,j-j3))) end do end do fx(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1,1) if (j3.eq.1) then do j=jllim,mp do i=illim,np temp(i,j,1)=(pe(i,j,1)*dyil* * (zs(i,j)-zs(i,j-j3)+zs(i-1,j)-zs(i-1,j-j3))) end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1,1) end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif fx(itd)=fx(itd)*dx*dy/drgnorm fy(itd)=fy(itd)*dx*dy/drgnorm #if (TIMEPLT == 1) call ttend(62) #endif return end subroutine sumcns(a,b,d,sum,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l), . b(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #endif C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else real sum #endif real globsum #if (TIMEPLT == 1) call ttbeg(63) #endif #if (POLES == 0) illim=1+ibcx*leftedge jllim=1+ibcy*botedge #else illim=1 jllim=1 #endif kllim=1+ibcz iflag=1-iflg do k=1,l do j=1,mp do i=1,np tmp(i,j,k)=0. enddo enddo enddo do k=kllim,l do j=jllim,mp do i=illim,np tmp(i,j,k)=(a(i,j,k)+iflag*b(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.0 .and. leftedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(1,j,k)=tmp(1,j,k)-0.5*(a(1,j,k)+iflag*b(1,j,k))*d(1,j,k) enddo enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(np,j,k)=tmp(np,j,k)-0.5*(a(np,j,k)+iflag*b(np,j,k))*d(np,j,k) enddo enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,1,k)=tmp(i,1,k)-0.5*(a(i,1,k)+iflag*b(i,1,k))*d(i,1,k) enddo enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,mp,k)=tmp(i,mp,k)-0.5*(a(i,mp,k)+iflag*b(i,mp,k))*d(i,mp,k) enddo enddo endif #endif if(ibcz.eq.0) then do j=jllim,mp do i=illim,np tmp(i,j,1)=tmp(i,j,1)-0.5*(a(i,j,1)+iflag*b(i,j,1))*d(i,j,1) tmp(i,j,l)=tmp(i,j,l)-0.5*(a(i,j,l)+iflag*b(i,j,l))*d(i,j,l) enddo enddo endif sum=globsum(tmp,1-ih,np+ih,1-ih,mp+ih, . 1,l,illim,np,jllim,mp,kllim,l) #if (TIMEPLT == 1) call ttend(63) #endif return end subroutine sumcnsB(a,sum) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #endif C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else real sum !modgs c real*8 sum #endif real globsum !modgs c real*8 globsum illim=1+ibcx*leftedge jllim=1+ibcy*botedge kllim=1+ibcz do k=1,l do j=1,mp do i=1,np tmp(i,j,k)=0. enddo enddo enddo do k=kllim,l do j=jllim,mp do i=illim,np tmp(i,j,k)=a(i,j,k) enddo enddo enddo if(ibcx.eq.0 .and. leftedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(1,j,k)=tmp(1,j,k)-0.5*a(1,j,k) enddo enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(np,j,k)=tmp(np,j,k)-0.5*a(np,j,k) enddo enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,1,k)=tmp(i,1,k)-0.5*a(i,1,k) enddo enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,mp,k)=tmp(i,mp,k)-0.5*a(i,mp,k) enddo enddo endif if(ibcz.eq.0) then do j=jllim,mp do i=illim,np tmp(i,j,1)=tmp(i,j,1)-0.5*a(i,j,1) tmp(i,j,l)=tmp(i,j,l)-0.5*a(i,j,l) enddo enddo endif sum=globsum(tmp,1-ih,np+ih,1-ih,mp+ih, . 1,l,illim,np,jllim,mp,kllim,l) return end #if (MOISTMOD > 0) subroutine totwtr(qv,qc,qr,d,qws) include 'param.nml' include 'msg.inc' dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #if (SUMR16 == 1) real*16 totws #else c real totws real*8 totws #endif #if (TIMEPLT == 1) call ttbeg(59) #endif totws=0. #if (PARALLEL > 0) #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*j3*topedge #else iulim=np julim=mp #endif kulim=l-ibcz do j=1,julim do i=1,iulim do k=1,kulim temp(i,j,k)=(qv(i,j,k)+qc(i,j,k)+qr(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) c if(ibcx.eq.0 .and. leftedge.eq.1) then c do k=1,kulim c do j=1,julim c temp(1,j,k)= c . temp(1,j,k)-0.5*(qv(1,j,k)+qc(1,j,k)+qr(1,j,k))*d(1,j,k) c enddo c enddo c endif c if(ibcx.eq.0 .and. rightedge.eq.1) then c do k=1,kulim c do j=1,julim c temp(np,j,k)= c . temp(np,j,k)-0.5*(qv(np,j,k)+qc(np,j,k)+qr(np,j,k))*d(np,j,k) c enddo c enddo c endif c if(ibcy.eq.0 .and. botedge.eq.1) then c do k=1,kulim c do i=1,iulim c temp(i,1,k)= c . temp(i,1,k)-0.5*(qv(i,1,k)+qc(i,1,k)+qr(i,1,k))*d(i,1,k) c enddo c enddo c endif c if(ibcy.eq.0 .and. topedge.eq.1) then c do k=1,kulim c do i=1,iulim c temp(i,mp,k)= c . temp(i,mp,k)-0.5*(qv(i,mp,k)+qc(i,mp,k)+qr(i,mp,k))*d(i,mp,k) c enddo c enddo c endif #endif c if(ibcz.eq.0) then do j=1,julim do i=1,iulim temp(i,j,1)= . temp(i,j,1)-0.5*(qv(i,j,1)+qc(i,j,1)+qr(i,j,1))*d(i,j,1) temp(i,j,l)= . temp(i,j,l)-0.5*(qv(i,j,l)+qc(i,j,l)+qr(i,j,l))*d(i,j,l) enddo enddo c endif totws=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . 1,iulim,1,julim,1,kulim) #else totws=0. do k=1,l-ibcz do j=1,mp-ibcy*j3 do i=1,np-ibcx totws=totws+(qv(i,j,k)+qc(i,j,k)+qr(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) do j=1,mp-ibcy*j3 do i=1,np-ibcx #else do j=1,mp do i=1,np #endif totws=totws - .5*(qv(i,j,1)+qc(i,j,1)+qr(i,j,1))*d(i,j,1) 1 - .5*(qv(i,j,l)+qc(i,j,l)+qr(i,j,l))*d(i,j,l) enddo enddo #endif qws=totws #if (TIMEPLT == 1) call ttend(59) #endif return end #endif subroutine diagnos(u,v,w,ox,oy,oz,th,p,x,y,z,rho,the,rh,div, * thsum0,chm,g1,g2,g3,tt,tend,qv,qc,qr,qia,qib, * qws0,rhm,dtm,drgx,drgy,zs,zh,bx,by,bz,divb) c * qws0,rhm,dtm,drgx,drgy,zs,zh) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . y(1-ih:np+ih, 1-ih:mp+ih, l), . z(1-ih:np+ih, 1-ih:mp+ih, l), . rho(1-ih:np+ih, 1-ih:mp+ih, l), . the(1-ih:np+ih, 1-ih:mp+ih, l), . rh(1-ih:np+ih, 1-ih:mp+ih, l), . div(1-ih:np+ih, 1-ih:mp+ih, l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . divb(1-ih:np+ih, 1-ih:mp+ih, l), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . chmx(nspc),chmn(nspc),chav(nspc), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . rhm(1-ih:np+ih, 1-ih:mp+ih, l), . zs(1-ih:np+ih, 1-ih:mp+ih), . zh(1-ih:np+ih, 1-ih:mp+ih) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . tmp4(1-ih:np+ih, 1-ih:mp+ih, l), . scr10(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . tmp4(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/stresd/ primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd, * ivis,irid,itstr real kmmx,kmmn,kmav,kmsd common/strese/ rimx,rimn,riav,risd, * stmx,stmn,stav,stsd, * dfmx,dfmn,dfav,dfsd data ifirst/0/ common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/dftemp/dftmx,dftmn,dftav,dftsd common/dissbc/ cstab,c00,c0h,dlstb,dtah,dtau,ntah,ntau common /water_bgdt/ totw0,totw(nth),prec(nth),sflux(nth), 1 prec_dis(np,mp) real globmax,globmin,globsum #if (TIMEPLT == 1) call ttbeg(60) #endif xnorm=(1-igrid)/float(l*m*n)+igrid/float((l-1)*(m-j3)*(n-1)) xnormj=1./float((l-2)*(m-2*j3)*(n-2)) nml=n*m*l check lipshitz and courant numbers call lipsch(ox,oy,oz,rho,g1,g2,g3,cr1,cr2,1,1) check variables bounds umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 pmx=-1.e15 pmn= 1.e15 tmx=-1.e15 tmn= 1.e15 zsmx=-1.e15 zsmn= 1.e15 zhmx=-1.e15 zhmn= 1.e15 do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 tmp1(i,j,k)=th(i,j,k)+the(i,j,k) umx=max(umx,globmax(u,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) umn=min(umn,globmin(u,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) vmx=max(vmx,globmax(v,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) vmn=min(vmn,globmin(v,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) wmx=max(wmx,globmax(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) wmn=min(wmn,globmin(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmx=max(pmx,globmax(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmn=min(pmn,globmin(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmx=pmx*2.*dti pmn=pmn*2.*dti tmx=max(tmx,globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) tmn=min(tmn,globmin(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) zsmx=max(zsmx,globmax(zs,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zsmn=min(zsmn,globmin(zs,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zhmx=max(zhmx,globmax(zh,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zhmn=min(zhmn,globmin(zh,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) call sumcns(th,p,rho,tsm0,0) if (thsum0.ne.0) then tsm=(tsm0-thsum0)/thsum0 else tsm=tsm0 endif if (mype.eq.0) then print 201,umx,umn,vmx,vmn,wmx,wmn,pmx,pmn,tmx,tmn,tsm, 1 zsmx,zsmn,zhmx,zhmn 201 format(1x,'umax, umin:',2e24.16/ 2 1x,'vmax, vmin:',2e24.16/ 3 1x,'wmax, wmin:',2e24.16/ 4 1x,'pmax, pmin:',2e24.16/ 5 1x,'thmx, thmn:',2e24.16,2x,'thsum:',e24.16/ 6 1x,'zsmx, zsmn:',2e24.16/ 7 1x,'zhmx, zhmn:',2e24.16) end if if(ichm.eq.1) then do ispc=1,nspc chmx(ispc)=-1.e15 chmn(ispc)= 1.e15 chav(ispc)=0. chmx(ispc)=max(chmx(ispc), globmax(chm(1-ih,1-ih,1,ispc) . ,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) chmn(ispc)=min(chmn(ispc), globmin(chm(1-ih,1-ih,1,ispc) . ,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) chav(ispc)=globsum(chm(1-ih,1-ih,1,ispc),1-ih,np+ih,1-ih, . mp+ih,1,l,illim,np,jllim,mp,1+igrid,l) chav(ispc)=chav(ispc)*xnorm if (mype.eq.0) print 202,ispc,chmx(ispc),chmn(ispc),chav(ispc) 202 format(1x,'ispc,chmx,chmn,chav:',i2,3e11.4) enddo endif #if (SEMILAG == 1) check lagrangian jacobian call update(x,np,mp,l,np,mp,1) call update(y,np,mp,l,np,mp,1) call update(z,np,mp,l,np,mp,1) gacmx=-1.e15 gacmn= 1.e15 gacav=0. gacsd=0. gacmxt=-1.e15 gacmnt= 1.e15 gacavt=0. gacsdt=0. #if (J3DIM == 1) #if (POLES == 0) jllim=1 +j3*botedge julim=mp-j3*topedge illim=1 +leftedge iulim=np-rightedge #else jllim=1 julim=mp illim=1 iulim=np #endif do 3 k=2,l-1 do 3 j=jllim,julim do 3 i=illim,iulim dxx= x(i+1,j,k)-x(i-1,j,k) dxy= x(i,j+j3,k)-x(i,j-j3,k) dxz= x(i,j,k+1)-x(i,j,k-1) dyx= y(i+1,j,k)-y(i-1,j,k) dyy= y(i,j+j3,k)-y(i,j-j3,k) dyz= y(i,j,k+1)-y(i,j,k-1) dzx= z(i+1,j,k)-z(i-1,j,k) dzy= z(i,j+j3,k)-z(i,j-j3,k) dzz= z(i,j,k+1)-z(i,j,k-1) #if (POLES == 0) if(ibcx.eq.1.and.dxx.gt. .25*n) dxx=dxx-float(n-1) if(ibcx.eq.1.and.dxx.lt.-.25*n) dxx=dxx+float(n-1) if(ibcy.eq.1.and.dyy.gt. .25*m) dyy=dyy-float(m-1) if(ibcy.eq.1.and.dyy.lt.-.25*m) dyy=dyy+float(m-1) #else c if(dxx.gt. .25*n) dxx=dxx-float(n-2) c if(dxx.lt.-.25*n) dxx=dxx+float(n-2) if(dxx.gt. .25*n) dxx=dxx-float(n) if(dxx.lt.-.25*n) dxx=dxx+float(n) if(dyy.gt. .25*m) dyy=dyy-float(m) if(dyy.lt.-.25*m) dyy=dyy+float(m) #endif gac=.125*( dxx*dyy*dzz+dxy*dyz*dzx+dxz*dyx*dzy 1 -dzx*dyy*dxz-dzy*dyz*dxx-dzz*dyx*dxy )*rh(i,j,k)/rho(i,j,k) gacmxt=amax1(gacmxt,gac) gacmnt=amin1(gacmnt,gac) gacavt=gacavt+gac gacsdt=gacsdt+(gac-1.)**2 3 continue #else #if (POLES == 0) if (leftedge.eq.1) then illim=2 else illim=1 end if if (rightedge.eq.1) then iulim=np-1 else iulim=np end if #else illim=1 iulim=np #endif do 31 k=2,l-1 do 31 i=illim,iulim dxx= x(i+1,1,k)-x(i-1,1,k) dxz= x(i,1,k+1)-x(i,1,k-1) dzx= z(i+1,1,k)-z(i-1,1,k) dzz= z(i,1,k+1)-z(i,1,k-1) #if (POLES == 0) if(ibcx.eq.1.and.dxx.gt. .25*n) dxx=dxx-float(n-1) if(ibcx.eq.1.and.dxx.lt.-.25*n) dxx=dxx+float(n-1) #else if(dxx.gt. .25*n) dxx=dxx-float(n) if(dxx.lt.-.25*n) dxx=dxx+float(n) #endif gac=.25*(dxx*dzz-dzx*dxz)*rh(i,1,k)/rho(i,1,k) gacmxt=amax1(gacmxt,gac) gacmnt=amin1(gacmnt,gac) gacavt=gacavt+gac gacsdt=gacsdt+(gac-1.)**2 31 continue #endif gacmx=max(gacmx,globmax(gacmxt,1,1,1,1,1,1,1,1,1,1,1,1)) gacmn=min(gacmn,globmin(gacmnt,1,1,1,1,1,1,1,1,1,1,1,1)) gacav=globsum(gacavt,1,1,1,1,1,1,1,1,1,1,1,1) gacsd=globsum(gacsdt,1,1,1,1,1,1,1,1,1,1,1,1) gacav=gacav*xnormj gacsd=sqrt(gacsd*xnormj) if (mype.eq.0) then print 203, gacmx,gacmn,gacav,gacsd 203 format(1x,'jcmx,jcmn,jcav,jcsd:',4f11.8) end if #endif check eulerian divergence igri3=igrid*j3 divmx=-1.e15 divmn= 1.e15 divav=0. if (leftedge.eq.1) then illim=1+igrid else illim=1 end if if (botedge.eq.1) then jllim=1+igri3 else jllim=1 end if divmx=globmax(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divmn=globmin(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=globsum(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=divav*xnorm divsd=0. do k=1+igrid,l do j=jllim,mp do i=illim,np tmp1(i,j,k)=(div(i,j,k)-divav)**2 end do end do end do divsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divsd=sqrt(divsd*xnorm) divmx=divmx*dt divmn=divmn*dt divav=divav*dt divsd=divsd*dt nitav=nitsm/max0(icount,1) mitav=mitsm/max0(jcount,1) if (mype.eq.0) then print 205, divmx,divmn,divav,divsd,eer,eem, . niter,nitav,miter,mitav 205 format(1x,'dvmx,dvmn,dvav,dvsd:',4e11.4/ . 1x,' eer,eem:',2e11.4/ 1 1x,'niter,nitav,miter,mitav:',4i4) end if check integrability condition for time-dependent bottom imass=1 ! print out global mass flux info if(tt.le.tend .and. tt.ne.0.) then tmass=0. tmass=globsum(rho,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) tmass=tmass*dx*dy*dz flinf=uinf+vinf+oinf+tflx flout=uout+vout+oout dmass=flinf+flout dmass=dmass/tmass ttnorm=tt/tend if (mype.eq.0.and.imass.eq.1) then print 206, tt,tend,ttnorm, * uinf,vinf,oinf, * uout,vout,oout, * tflx,flinf,flout, * dmass,epsim,epsia 206 format(1x,'tt, tend, ttnorm:',3e11.4/ 1 1x,'uinf, vinf, oinf:',3e11.4/ 2 1x,'uout, vout, oout:',3e11.4/ 3 1x,'tflx, finf, fout:',3e11.4/ 4 1x,'dmas, epsm, epsa:',3e11.4) end if endif if(irid.eq.1) then call rical(u,v,w,th,qv,qc,0) rimx=-1.e15 rimn= 1.e15 riav=0. stmx=-1.e15 stmn= 1.e15 stav=0. dfmx=-1.e15 dfmn= 1.e15 dfav=0. rimx=globmax(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) rimn=globmin(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) riav=globsum(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stmx=globmax(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stmn=globmin(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stav=globsum(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfmx=globmax(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfmn=globmin(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfav=globsum(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) riav=riav/float(nml) dfav=dfav/float(nml) stav=stav/float(nml) risd=0. stsd=0. dfsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(ri(i,j,k)-riav)**2 tmp2(i,j,k)=(stab(i,j,k)-stav)**2 tmp3(i,j,k)=(defsq(i,j,k)-dfav)**2 end do end do end do risd = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stsd = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfsd = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) risd=sqrt(risd/float(nml-1)) stsd=sqrt(stsd/float(nml-1)) dfsd=sqrt(dfsd/float(nml-1)) if(rimn.le.0. .and. ifirst.eq.0) then ifirst=1 c---locate position of minimum Ri do k=1,L do j=1,mp do i=1,np if(abs(ri(i,j,k)-rimn).lt.1.0e-10) then ia=(npos-1)*np + i ja=(mpos-1)*mp + j irimin = ia jrimin = ja krimin = k endif enddo enddo enddo if (mype.eq.0) print 2059, rimn,irimin,jrimin,krimin 2059 format(' first negative Rimin=', e11.4,' at i,j,k=',3i4) endif if (mype.eq.0) then print 2060, rimx,rimn,riav,risd, 1 stmx,stmn,stav,stsd, 2 dfmx,dfmn,dfav,dfsd 2060 format(1x,'rimx, rimn, riav, risd:',4e11.4/ 1 1x,'stmx, stmn, stav, stsd:',4e11.4/ 2 1x,'dfmx, dfmn, dfav, dfsd:',4e11.4) end if endif if(ivis.eq.1) then if (mype.eq.0) then deldf=dt*(dxi**2+j3*dyi**2+dzi**2) ckmmx=kmmx*deldf ckmmn=kmmn*deldf ckmav=kmav*deldf ckmsd=kmsd*deldf print 2061, primx,primn,priav,prisd, 1 ckmmx,ckmmn,ckmav,ckmsd 2061 format(1x,'primx, primn, priav, prisd:',4e11.4/ 1 1x,' kmmx, kmmn, kmav, kmsd:',4e11.4) end if endif if (mype.eq.0.and.idrag.eq.1) then print 2062,drgx, drgy, drgnorm ! NOTE: drgx,drgy undefined 2062 format(1x,'drgx, drgy, drgnorm:',3e11.4) end if check boundary velocities ibound=1 ! print out boundary velocities do 7 k=1,l,l-1 ommx=-1.e15 ommn= 1.e15 ommx=max(ommx,globmax(oz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) ommn=min(ommn,globmin(oz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) if (mype.eq.0.and.ibound.eq.1) print 207,k,ommx,ommn 7 continue ummx=-1.e15 ummn= 1.e15 do k=1,l do j=1,mp do i=1,np,np-1 tmp1(i,j,k)=ummx tmp2(i,j,k)=ummn end do end do end do if (leftedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=ox(1,j,k) tmp2(1,j,k)=ox(1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(np,j,k)=ox(np,j,k) tmp2(np,j,k)=ox(np,j,k) end do end do end if ummx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp,1,l) ummn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then i=1 print 208,i,ummx,ummn end if #if (PARALLEL == 1) #if (CRAYT3D == 1) call mybarrier() #endif #endif ummx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,np,np,1,mp,1,l) ummn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,np,np,1,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then i=n print 208,i,ummx,ummn end if vmmx=-1.e15 vmmn= 1.e15 do k=1,l do j=1,mp,mp-j3 do i=1,np tmp1(i,j,k)=vmmx tmp2(i,j,k)=vmmn end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=oy(i,1,k) tmp2(i,1,k)=oy(i,1,k) end do end do end if vmmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1,1,l) vmmn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1,1,l) if (mype.eq.0.and.ibound.eq.1) then j=1 print 209,j,vmmx,vmmn end if if (j3.eq.1) then #if (PARALLEL == 1) #if (CRAYT3D == 1) call mybarrier() #endif #endif if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,mp,k)=oy(i,mp,k) tmp2(i,mp,k)=oy(i,mp,k) end do end do end if vmmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,mp,mp,1,l) vmmn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,mp,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then j=m print 209,j,vmmx,vmmn end if end if 207 format(1x,'k,ommx,ommn:',i5,2e11.4) 208 format(1x,'i,ummx,ummn:',i5,2e11.4) 209 format(1x,'j,vmmx,vmmn:',i5,2e11.4) cyclicity check if(ibcx+ibcy+ibcz.ne.0) then call ckcyc( u,1,1,l) call ckcyc( v,2,1,l) call ckcyc( w,3,1,l) ccc call ckcyc( p,4,1,l) call ckcyc(th,5,1,l) endif if(mhd.eq. 1) then xmiu=4.e-7*acos(-1.) !magnetic permeability bxmx=-1.e15 bxmn= 1.e15 bymx=-1.e15 bymn= 1.e15 bzmx=-1.e15 bzmn= 1.e15 bxmx=amax1(bxmx, . globmax(bx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bxmn=amin1(bxmn, . globmin(bx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bymx=amax1(bymx, . globmax(by,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bymn=amin1(bymn, . globmin(by,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bzmx=amax1(bzmx, . globmax(bz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bzmn=amin1(bzmn, . globmin(bz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) if (mype.eq.0) then print 701,bxmx,bxmn,bymx,bymn,bzmx,bzmn 701 format(1x,'bxmx, bxmn:',2e24.16/ 1 1x,'bymx, bymn:',2e24.16/ 2 1x,'bzmx, bzmn:',2e24.16) endif check induction divergence igri3=igrid*j3 divmx=-1.e15 divmn= 1.e15 divav=0. if (leftedge.eq.1) then illim=1+igrid else illim=1 end if if (botedge.eq.1) then jllim=1+igri3 else jllim=1 end if divmx=globmax(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divmn=globmin(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=globsum(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=divav*xnorm divsd=0. do k=1+igrid,l do j=jllim,mp do i=illim,np tmp1(i,j,k)=(divb(i,j,k)-divav)**2 end do end do end do divsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divsd=sqrt(divsd*xnorm) divmx=divmx*dt/sqrt(100.*xmiu) divmn=divmn*dt/sqrt(100.*xmiu) divav=divav*dt/sqrt(100.*xmiu) divsd=divsd*dt/sqrt(100.*xmiu) nitab=nitsb/max0(icounb,1) mitab=mitsb/max0(jcounb,1) if (mype.eq.0) then print 705, divmx,divmn,divav,divsd,erb,emb, . niteb,nitab,miteb,mitab 705 format(1x,'dvBmx,dvBmn,dvBav,dvBsd:',4e11.4/ . 1x,' eer,eem:',2e11.4/ 1 1x,'niteb,nitab,miteb,mitab:',4i4) end if cyclicity check if(ibcx+ibcy+ibcz.ne.0) then call ckcyc(bx,31,1,l) call ckcyc(by,32,1,l) call ckcyc(bz,33,1,l) endif endif !mhd #if (MOISTMOD > 0) check moist model if(moist.eq.1) then qvmx=-1.e15 qvmn= 1.e15 qcmx=-1.e15 qcmn= 1.e15 qrmx=-1.e15 qrmn= 1.e15 qtot=0. qvmx=amax1(qvmx, . globmax(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qvmn=amin1(qvmn, . globmin(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmx=amax1(qcmx, . globmax(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmn=amin1(qcmn, . globmin(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmx=amax1(qrmx, . globmax(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmn=amin1(qrmn, . globmin(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) call totwtr(qv,qc,qr,rho,qws) qtot=(qws-qws0)/qws0 totw0=qws*dz*dy*dz if (mype.eq.0) then print 301,qvmx,qvmn,qcmx,qcmn,qrmx,qrmn,qtot print 302,dftmx,dftmn,dftav,dftsd print*,' total water: ',totw0 301 format(1x,'qvmx, qvmn:',2e11.4/ 1 1x,'qcmx, qcmn:',2e11.4/ 2 1x,'qrmx, qrmn:',2e11.4,2x,'qtot:',e11.4) 302 format(1x,'dftmx, dftmn, dftav, dftsd:',4e11.4) endif #if (POLES == 0) if(ibcx+ibcy+ibcz.ne.0) then call ckcyc(qv,7,1,l) call ckcyc(qc,8,1,l) call ckcyc(qr,9,1,l) endif #endif call rhfld(th,qv,rhm,n,m,l,1) cc surface precip: day=24.*3600. do j=1,mp do i=1,np tmp1(i,j,1)=prec_dis(i,j)/float(noutp)*day prec_dis(i,j)=0. end do end do prmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) prmn=globmin(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) if (mype.eq.0) print 317,prmx,prmn 317 format(1x,'max, min surf. precip (mm/day):',2e11.4) endif #endif #if (TIMEPLT == 1) call ttend(60) #endif return end subroutine lipsch(u,v,w,d,g1,g2,g3,cr1,cr2,lagr0,iprnt) c ---- computes infinity norms for Courant and Lipshitz numbers include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif #if (PARALLEL > 0) dimension tempcr2(1-ih:1+ih, 1-ih:1+ih) #endif real globmax #if (TIMEPLT == 1) call ttbeg(61) #endif call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) nml=n*m*l cr1=0. cr2=0. jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + leftedge iulim = np - rightedge if(lagr0.eq.1) then c --- compute Courant number do k=1,l do j=1,mp do i=1,np temp(i,j,k)=g1*abs(u(i,j,k)) + . g2*abs(v(i,j,k)) + . g3*abs(w(i,j,k)) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) c --- compute Lipshitz number do 2 k=2,l-1 do 2 j=jllim,julim do 2 i=illim,iulim 2 cr2=amax1(cr2, .5*g1*abs( u(i+1,j,k)-u(i-1,j,k) ), 1 .5*g2*abs( u(i,j+j3,k)-u(i,j-j3,k) ), 1 .5*g3*abs( u(i,j,k+1)-u(i,j,k-1) ), 2 .5*g1*abs( v(i+1,j,k)-v(i-1,j,k) ), 2 .5*g2*abs( v(i,j+j3,k)-v(i,j-j3,k) ), 2 .5*g3*abs( v(i,j,k+1)-v(i,j,k-1) ), 3 .5*g1*abs( w(i+1,j,k)-w(i-1,j,k) ), 3 .5*g2*abs( w(i,j+j3,k)-w(i,j-j3,k) ), 3 .5*g3*abs( w(i,j,k+1)-w(i,j,k-1) )) else c --- compute Courant number normalized by density do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(abs(u(i,j,k)) + . abs(v(i,j,k)) + . abs(w(i,j,k)))/d(i,j,k) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) c --- compute Lipshitz number normalized by density gy=j3*g2+(1-j3)*1. do 20 k=2,l-1 do 20 j=jllim,julim do 20 i=illim,iulim 20 cr2=amax1(cr2,.5*g1/g1*abs( u(i+1,j,k)-u(i-1,j,k) )/d(i,j,k), 1 .5*g2/g1*abs( u(i,j+j3,k)-u(i,j-j3,k) )/d(i,j,k), 1 .5*g3/g1*abs( u(i,j,k+1)-u(i,j,k-1) )/d(i,j,k), 2 .5*g1/gy*abs( v(i+1,j,k)-v(i-1,j,k) )/d(i,j,k), 2 .5*g2/gy*abs( v(i,j+j3,k)-v(i,j-j3,k) )/d(i,j,k), 2 .5*g3/gy*abs( v(i,j,k+1)-v(i,j,k-1) )/d(i,j,k), 3 .5*g1/g3*abs( w(i+1,j,k)-w(i-1,j,k) )/d(i,j,k), 3 .5*g2/g3*abs( w(i,j+j3,k)-w(i,j-j3,k) )/d(i,j,k), 3 .5*g3/g3*abs( w(i,j,k+1)-w(i,j,k-1) )/d(i,j,k)) endif #if (PARALLEL > 0) tempcr2(1,1)=cr2 cr2=globmax(tempcr2,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) #endif if(iprnt.eq.1) then if (mype.eq.0) then print 201,cr1,cr2 end if 201 format(1x,'cour,lipsh:',2e11.4) endif #if (TIMEPLT == 1) call ttend(61) #endif return end subroutine courB(bx,by,bz,d,xmiu,cr1,iprnt) c ---- computes infinity norms for Courant and Lipshitz numbers include 'param.nml' include 'msg.inc' dimension bx(1-ih:np+ih, 1-ih:mp+ih, l), . by(1-ih:np+ih, 1-ih:mp+ih, l), . bz(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/ohm/ pm(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 u(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 v(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 w(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 frcb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif #if (PARALLEL > 0) dimension tempcr2(1-ih:1+ih, 1-ih:1+ih) #endif real globmax cr1=0. if(mhd.eq.0) return do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) u(i,j,k)= G11*bx(i,j,k)+G21*by(i,j,k) v(i,j,k)= G12*bx(i,j,k)+G22*by(i,j,k) w(i,j,k)= G13*bx(i,j,k)+G23*by(i,j,k)+G33*bz(i,j,k) denom=sqrt(xmiu*(d(i,j,k)/rh0(i,j,k))) denomi=1./denom u(i,j,k)=u(i,j,k)*denomi v(i,j,k)=v(i,j,k)*denomi w(i,j,k)=w(i,j,k)*denomi enddo enddo enddo call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) nml=n*m*l jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + leftedge iulim = np - rightedge g1=dt*dxi g2=dt*dyi g3=dt*dzi c --- compute Courant number do k=1,l do j=1,mp do i=1,np temp(i,j,k)=g1*abs(u(i,j,k)) + g2*abs(v(i,j,k)) + . g3*abs(w(i,j,k)) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if(iprnt.eq.1) then if (mype.eq.0) then print 201,cr1 end if 201 format(1x,'Alfven wave cour:',e11.4) endif return end subroutine pminmax(a,n1,n2,n3,strng) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, n3) character (*) strng real globmax,globmin flocmin=1.e10 flocmax=-1.e10 flocsum=0. do k=1,n3 do j=1,n2 do i=1,n1 flocmin=min(flocmin,a(i,j,k)) flocmax=max(flocmax,a(i,j,k)) flocsum=flocsum+a(i,j,k) end do end do end do fglobmax=globmax(flocmax,1,1,1,1,1,1,1,1,1,1,1,1) fglobmin=globmin(flocmin,1,1,1,1,1,1,1,1,1,1,1,1) fglobsum=globsum(flocsum,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) then print *,'min max: ',strng,fglobmin,fglobmax,flocsum endif return end subroutine ckcyc_old(a,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc real globmax,globmin dimension tmpxmin(1,mp,l),tmpxmax(1,mp,l) dimension tmpymin(np,1,l),tmpymax(np,1,l) dimension tmpzmin(np,mp,1),tmpzmax(np,mp,1) call update2(a,np,mp,l,np,mp,1) if(ibcx.eq.1) then cmx0=-1.e15 cmn0= 1.e15 #if (POLES == 0) do k=1,l do j=1,mp tmpxmax(1,j,k)=cmx0 tmpxmin(1,j,k)=cmn0 end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmpxmax(1,j,k)=(a(np,j,k) - a(np+1,j,k)) tmpxmin(1,j,k)=(a(np,j,k) - a(np+1,j,k)) end do end do end if cmx=globmax(tmpxmax,1,1,1,mp,1,l,1,1,1,mp,1,l) cmn=globmin(tmpxmin,1,1,1,mp,1,l,1,1,1,mp,1,l) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) #endif if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 100,cmx,cmn 100 format(12x,'ibcx periodicity check; dmx, dmn=',2e11.4) endif endif endif if(ibcy.eq.1) then cmx0=-1.e15 cmn0= 1.e15 #if (POLES == 0) do k=1,l do i=1,np tmpymax(i,1,k)=cmx0 tmpymin(i,1,k)=cmn0 end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmpymax(i,1,k) = (a(i,mp+1,k) - a(i,mp,k)) tmpymin(i,1,k) = (a(i,mp+1,k) - a(i,mp,k)) end do end do end if cmx=globmax(tmpymax,1,np,1,1,1,l,1,np,1,1,1,l) cmn=globmin(tmpymin,1,np,1,1,1,l,1,np,1,1,1,l) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) #endif if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 200,cmx,cmn 200 format(12x,'ibcy periodicity check; dmx, dmn=',2e11.4) endif endif endif if(ibcz.eq.1) then cmx0=-1.e15 cmn0= 1.e15 do j=1,mp do i=1,np tmpzmax(i,j,1)=(a(i,j,l) - a(i,j,1)) tmpzmin(i,j,1)=(a(i,j,l) - a(i,j,1)) end do end do cmx=globmax(tmpzmax,1,np,1,mp,1,1,1,np,1,mp,1,1) cmn=globmin(tmpzmin,1,np,1,mp,1,1,1,np,1,mp,1,1) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 300,cmx,cmn 300 format(12x,'ibcz periodicity check; dmx, dmn=',2e11.4) endif endif endif return end subroutine ckcyc(a,iflg,iupdate,n3) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, n3) character *7 aflag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc real globmax,globmin #if (TIMEPLT == 1) call ttbeg(64) #endif if(iupdate.eq.1) call update2(a,np,mp,n3,np,mp,1) if(iflg.eq.1) aflag='u ' if(iflg.eq.2) aflag='v ' if(iflg.eq.3) aflag='w ' if(iflg.eq.4) aflag='p ' if(iflg.eq.5) aflag='th ' if(iflg.eq.6) aflag='qv ' if(iflg.eq.7) aflag='qc ' if(iflg.eq.8) aflag='qr ' if(iflg.eq.10) aflag='qia ' if(iflg.eq.11) aflag='qib ' #if (POLES == 0) if(ibcx.eq.1) then cmx =-1.e15 cmn = 1.e15 cm1 = 0. cm2 = 0. jx=0 kx=0 if (rightedge.eq.1) then do k=1,n3 do j=1,mp ck=a(np,j,k)-a(np+1,j,k) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then jx=j kx=k cm1=a(np,j,k) cm2=a(np+1,j,k) endif end do end do end if cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 100,mype,aflag,jx,kx,cmxg,cmng,cm1,cm2 endif endif endif if(ibcy.eq.1) then cmx=-1.e15 cmn= 1.e15 iy=0 ky=0 cm1 = 0. cm2 = 0. if (topedge.eq.1) then do k=1,n3 do i=1,np ck=a(i,mp+1,k)-a(i,mp,k) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then iy=i ky=k cm1=a(i,mp,k) cm2=a(i,mp+1,k) endif end do end do end if cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 200,mype,aflag,iy,ky,cmxg,cmng,cm1,cm2 endif endif endif #endif if((ibcz.eq.1).and.(n3.gt.1)) then cmx=-1.e15 cmn= 1.e15 iz=0 jz=0 cm1 = 0. cm2 = 0. do j=1,mp do i=1,np ck=a(i,j,l)-a(i,j,1) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then iz=i jz=j cm1=a(i,j,1) cm2=a(i,j,l) endif end do end do cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 300,mype,aflag,iz,jz,cmxg,cmng,cm1,cm2 endif endif endif 100 format(1x,i4,1x,a7,' ibcx j,k:',2i3,' mx,mn,a=',2e11.4,2e11.5) 200 format(1x,i4,1x,a7,' ibcy i,k:',2i3,' mx,mn,a=',2e11.4,2e11.5) 300 format(1x,i4,1x,a7,' ibcz i,j:',2i3,' mx,mn,a=',2e11.4,2e11.5) #if (TIMEPLT == 1) call ttend(64) #endif return end subroutine negck(a,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) real globmin fmn=1.e25 fmn=globmin(a,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if(fmn.ge.0.) then if(mype.eq.0) then if(iflg.eq.1) write (6,*) 'th nonegative' if(iflg.eq.6) write (6,*) 'qv nonegative' if(iflg.eq.7) write (6,*) 'qc nonegative' if(iflg.eq.8) write (6,*) 'qr nonegative' endif else if(mype.eq.0) then if(iflg.eq.1) write (6,*) 'th negatives' if(iflg.eq.6) write (6,*) 'qv negatives' if(iflg.eq.7) write (6,*) 'qc negatives' if(iflg.eq.8) write (6,*) 'qr negatives' endif do 1 k=1,l do 1 j=1,mp do 1 i=1,np if(a(i,j,k).lt.0.) then print 100, mype,i,j,k,a(i,j,k) endif 1 continue 100 format(2x,'mype:',i4,'i,j,k=',3i4,'value=',e11.4) endif return end subroutine rdtp(jt,u,v,w,ox,oy,oz,t,p,fx,fy,fz,ft, . fox,foy,foz,qv,qc,qr,fqv,fqc,fqr,tke,ftke,hise,epp1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . hise(nthv,2) real epp1 #if (TIMEPLT == 1) call ttbeg(85) #endif read (jt) u read (jt) v read (jt) w read (jt) ox read (jt) oy read (jt) oz read (jt) t read (jt) p read (jt) fx read (jt) fy read (jt) fz read (jt) ft read (jt) fox read (jt) foy read (jt) foz read (jt) qv read (jt) qc read (jt) qr read (jt) fqv read (jt) fqc read (jt) fqr read (jt) tke read (jt) ftke read (jt) hise read (jt) epp1 #if (TIMEPLT == 1) call ttend(85) #endif return end subroutine wrtp(it,u,v,w,ox,oy,oz,t,p,fx,fy,fz,ft, . fox,foy,foz,qv,qc,qr,fqv,fqc,fqr,tke,ftke,hise,epp1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . hise(nthv,2) real epp1 #if (TIMEPLT == 1) call ttbeg(86) #endif write (it) u write (it) v write (it) w write (it) ox write (it) oy write (it) oz write (it) t write (it) p write (it) fx write (it) fy write (it) fz write (it) ft write (it) fox write (it) foy write (it) foz write (it) qv write (it) qc write (it) qr write (it) fqv write (it) fqc write (it) fqr write (it) tke write (it) ftke write (it) hise write (it) epp1 #if (TIMEPLT == 1) call ttend(86) #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C S E T P R O C E S S O R S G E O M E T R Y C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine geomset() c c setup geometry information for each processor c include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (PARALLEL > 0) #include "msg.lnk" integer iranks(nproc), flag C---------------------------------------------------------------------- #if (PARALLEL == 2) integer :: proc_eu, isize, irank, ieupe #if (HP == 2 || FUJI_VPP == 2 || IBM == 2 || PLE == 2 || LNX==2 ) DC_TYPE = MPI_DOUBLE_PRECISION #else DC_TYPE = MPI_REAL #endif call MPI_COMM_GET_ATTR(MPI_COMM_WORLD,MPI_APPNUM,ieupe,flag,ierr) call MPI_Comm_size(MPI_COMM_WORLD, isize, ierr) ! total numbers of PE's call MPI_Comm_rank(MPI_COMM_WORLD, irank, ierr) ! number of current PE C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !Split WORLD_COMM and get EULAG ranks (mype) and size/processors (proceu) call MPI_Comm_split(MPI_COMM_WORLD,ieupe,irank,MPI_COMM_EULAG,ierr +) call MPI_Comm_size(MPI_COMM_EULAG, proc_eu, ierr ) call MPI_Comm_rank(MPI_COMM_EULAG, mype, ierr) ! !Test for insconsistency in processors numbers ! CCC CCC CCC CCC CCC CCC if(proc_eu.ne.nprocx*nprocy) then if(mype.eq.0) then PRINT *,'!!!!!! WRONG PROC NUMBER !!!!!!' print *,'!!!!!! NPE .ne. nprocx*nprocy !!!!!!' print *,'NPE = ',isize,'nprocx*nprocy=',nprocx*nprocy print *,'!!!!!! EXIT !!!!!!' endif call MPI_BARRIER(ierr) call MPI_Finalize(ierr) STOP 'GEOMSET' endif if (tag_frn > 0) call bridge_init() #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) mysize = NUM_PES() #else mysize = N$PES #endif mype = my_pe() #endif C---------------------------------------------------------------------- c print *,'mype:',mype middle = 0 rightedge = 0 leftedge = 0 botedge = 0 topedge = 0 npos = mod((mype+nprocx), nprocx) + 1 mpos = mype/nprocx + 1 c print *,'mype, npos, mpos:',mype,npos,mpos if (mod((mype+1+nprocx), nprocx).eq.0) rightedge = 1 if (mod((mype+1+nprocx), nprocx).eq.1 .or. nprocx.eq.1) . leftedge = 1 if ((mype+1).le.nprocx) botedge = 1 if (((nprocx*nprocy) - (mype+1)) .lt. nprocx) topedge = 1 if (rightedge.eq.0 .and. leftedge.eq.0 .and. botedge.eq.0 . .and. topedge.eq.0) middle = 1 peleft=mype-1 if (peleft.lt.((mpos-1)*nprocx)) peleft=mype + (nprocx-1) peright=mype+1 if (peright.gt.(mpos*nprocx - 1)) peright=mype - (nprocx-1) #if(POLES == 0) peabove=mype+nprocx if (peabove.gt.(nprocx*nprocy-1)) peabove=npos-1 pebelow=mype-nprocx if (pebelow.lt.0) pebelow=mype+((nprocy-1)*nprocx) if (npos.lt.nprocx) then perightabove=peabove+1 perightbelow=pebelow+1 else perightabove=peabove-(nprocx-1) perightbelow=pebelow-(nprocx-1) end if if (npos.ne.1) then peleftabove=peabove-1 peleftbelow=pebelow-1 else peleftabove=peabove+(nprocx-1) peleftbelow=pebelow+(nprocx-1) end if #else peabove=mype+nprocx if (peabove.gt.(nprocx*nprocy-1)) then peabove=mype+nprocx/2 if (peabove.gt.(nprocx*nprocy-1)) peabove=peabove-nprocx endif pebelow=mype-nprocx if (pebelow.lt.0) then pebelow=mype-nprocx/2 if (pebelow.lt.0) pebelow=pebelow+nprocx endif if (npos.lt.nprocx) then perightabove=peabove+1 perightbelow=pebelow+1 else perightabove=peabove-(nprocx-1) perightbelow=pebelow-(nprocx-1) end if if (npos.ne.1) then peleftabove=peabove-1 peleftbelow=pebelow-1 else peleftabove=peabove+(nprocx-1) peleftbelow=pebelow+(nprocx-1) end if change corners position for bottom and top processors if (mpos.eq.1) then perightbelow=pebelow-1 if (perightbelow.lt.0) perightbelow=perightbelow+nprocx peleftbelow=pebelow+1 if (peleftbelow.gt.(nprocx-1)) . peleftbelow=peleftbelow-nprocx endif if (mpos.eq.nprocy) then perightabove=peabove-1 if (perightabove.lt.(nprocx*(nprocy-1))) . perightabove=perightabove+nprocx peleftabove=peabove+1 if (peleftabove.gt.(nprocx*nprocy-1)) . peleftabove=peleftabove-nprocx end if #endif C---------------------------------------------------------------------- ipri=0 if (ipri.eq.1) then if (mype.eq.0) then print 98,nprocx,nprocy print 99,mype,middle,rightedge,leftedge,botedge,topedge,npos,mpos, . peleft,peright,peabove,pebelow,perightabove, . perightbelow,peleftabove,peleftbelow endif call mybarrier() if (mype.ne.0) then print 99,mype,middle,rightedge,leftedge,botedge,topedge,npos,mpos, . peleft,peright,peabove,pebelow,perightabove, . perightbelow,peleftabove,peleftbelow endif call mybarrier() 98 format('nprocx = ',i3,' nprocy = ',i3,/, .' my mid R L B T N M pL pR pT pB pRT pRB pLT pLB') 99 format(i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ', . i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3) endif C---------------------------------------------------------------------- CCCCCCCC PARALLEL ZONAV myx_pe=mype/nprocx call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,my_row,ierr) if (botedge.eq.1) then ! PARALLEL ZONAV for SOUTH POLE myx_pe=mpos call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_south_pole,ierr) else myx_pe=0 call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_south_pole,ierr) endif if (topedge.eq.1) then ! PARALLEL ZONAV for NORTH POLE myx_pe=mpos call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_north_pole,ierr) else myx_pe=0 call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_north_pole,ierr) endif C---------------------------------------------------------------------- CCCCCCCC TRANSFER DATA from POLE in LATITUDE DIRECTION myy_pe=npos call MPI_Comm_split(MPI_COMM_EULAG,myy_pe,mype,my_col,ierr) c call MPI_Comm_size(my_row, size, ierr) ! total numbers of PE's c print *,'my_row',mype,size c call MPI_Barrier(MPI_COMM_EULAG, ierr) c call MPI_Comm_size(my_col, size, ierr) ! total numbers of PE's c print *,'my_col',mype,size C---------------------------------------------------------------------- CCCCCCC spectral cyclic reduction C goto 777 nn=(n+1)/2*ibcx+(1-ibcx)*n mm=(m+1)/2*ibcy+(1-ibcy)*m call mpi_comm_group(MPI_COMM_EULAG,iwgroup,ierr) cccccccccccccccccccccc do jpos=1,nprocy icount=0 do ipos=1,nprocx nnp=min(nssp,nn-(ipos-1)*np) ! local value of nn for ipos irank=ipos-1+(jpos-1)*nprocx ! processor rank on position (ipos,jpos) if(nnp.ge.1) then icount=icount+1 iranks(icount)=irank endif enddo c if(mype.eq.0) print *,jpos,'AAA:',icount,'proc:',iranks(1:icount) call mpi_group_incl(iwgroup,icount,iranks,irow_gr,ierr) call mpi_comm_create(MPI_COMM_EULAG,irow_gr,my_row_sp(jpos),ierr) call MPI_group_free(irow_gr,ierr) enddo cccccccccccccccccccccc do ipos=1,nprocx icount=0 do jpos=1,nprocy mmp=min(mssp,mm-(jpos-1)*mp) ! local value of mm for jpos irank=ipos-1+(jpos-1)*nprocx ! processor rank on position (ipos,jpos) if(mmp.ge.1) then icount=icount+1 iranks(icount)=irank endif enddo c if(mype.eq.0) print *,ipos,'BBB:',icount,'proc:',iranks(1:icount) call mpi_group_incl(iwgroup,icount,iranks,icol_gr,ierr) call mpi_comm_create(MPI_COMM_EULAG,icol_gr,my_col_sp(ipos),ierr) call MPI_group_free(icol_gr,ierr) enddo cccccccccccccccccccccc call MPI_Group_free(iwgroup,ierr) 777 continue C call MPI_Finalize(ierr) C stop #else mype = 0 middle = 0 rightedge = 1 leftedge = 1 botedge = 1 topedge = 1 npos = 1 mpos = 1 peleft = 0 peright = 0 peabove = 0 pebelow = 0 perightabove = 0 perightbelow = 0 peleftabove = 0 peleftbelow = 0 #endif iprint=0 if(iprint.eq.1) then print*,'parameters from subroutine geomset:' print *,mype,topedge,botedge,rightedge,leftedge, . my_row,m_south_pole, . m_north_pole,my_col end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C T E S T U P D A T E S P R O C E D U R E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine testreal include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,n0=10,l0=l) create model variables dimension u(1-ih:np+ih, 1-ih:mp+ih, l) dimension u2(1-ih:np+ih, 1-ih:mp+ih, l) dimension ulr(1-ih:np+ih, 1-ih:mp+ih, l) dimension ubt(1-ih:np+ih, 1-ih:mp+ih, l) dimension x(1-ior-ihlag:np+ior+ihlag, 1-ior-ihlag:mp+ior+ihlag, . 1-ior:l+ior) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check compute some relevant constants constants for computational grid print *,'Start Test' #if (POLES == 1) do i=1,n ip(i)=mod(i +n/2-1,n)+1 enddo #endif do k=1,l do j=1,mp do i=1,np u(i,j,k)=-k u2(i,j,k)=-k ulr(i,j,k)=-k ubt(i,j,k)=-k x(i,j,k)=-k enddo enddo enddo do j=1,mp do i=1,np u(i,j,1)=(mype*10000+j*100+i)*1. u2(i,j,1)=(mype*10000+j*100+i)*1. ulr(i,j,1)=(mype*10000+j*100+i)*1. ubt(i,j,1)=(mype*10000+j*100+i)*1. enddo enddo do j=1,mp do i=1,np x(i,j,1)=(mype*10000+j*100+i)*1. enddo enddo #if (PARALLEL == 1) call mybarrier() #endif call update(u,np,mp,l,np,mp,ih) call update2(u2,np,mp,l,np,mp,ih) call updatelr(ulr,np,mp,l,np,mp,ih) call updatebt(ubt,np,mp,l,np,mp,ih) #if (SEMILAG == 1) call updatelagr(x,np,mp,l+2*ior,np,mp,ihlag) #endif #if (PARALLEL == 1) call mybarrier() #endif iprintnow=0 77 continue #if (PARALLEL == 1) call mybarrier() #endif if (mype.eq.iprintnow) then print *,'update mype =',mype do j=mp+ih,1-ih,-1 print 99,u(-2,j,1),u(-1,j,1),u(0,j,1), . u(1,j,1),u(2,j,1),u(3,j,1), . u(np-2,j,1),u(np-1,j,1),u(np,j,1), . u(np+1,j,1),u(np+2,j,1),u(np+3,j,1) enddo print * print *,'update2 mype =',mype do j=mp+ih,1-ih,-1 print 99,u2(-2,j,1),u2(-1,j,1),u2(0,j,1), . u2(1 ,j,1),u2( 2,j,1),u2(3 ,j,1), . u2(np-2,j,1),u2(np-1,j,1),u2(np ,j,1), . u2(np+1,j,1),u2(np+2,j,1),u2(np+3,j,1) enddo print * print *,'updatelr mype =',mype do j=mp+ih,1-ih,-1 print 99,ulr(-2,j,1),ulr(-1,j,1),ulr(0,j,1), . ulr(1,j,1),ulr(2,j,1),ulr(3,j,1), . ulr(np-2,j,1),ulr(np-1,j,1),ulr(np,j,1), . ulr(np+1,j,1),ulr(np+2,j,1),ulr(np+3,j,1) enddo print * print *,'updatebt mype =',mype do j=mp+ih,1-ih,-1 print 99,ubt(-2,j,1),ubt(-1,j,1),ubt(0,j,1), . ubt(1,j,1),ubt(2,j,1),ubt(3,j,1), . ubt(np-2,j,1),ubt(np-1,j,1),ubt(np,j,1), . ubt(np+1,j,1),ubt(np+2,j,1),ubt(np+3,j,1) enddo print * #if (SEMILAG == 1) print *,'updatelgr mype =',mype do j=mp+ihlag+ior,1-ihlag-ior,-1 if(ior.eq.1) then print 96,x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1) elseif(ior.eq.2) then print 97,x(-4,j,1),x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1), . x(np+5,j,1) else print 98,x(-6,j,1),x(-5,j,1), . x(-4,j,1),x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1), . x(np+5,j,1),x(np+6,j,1),x(np+7,j,1) endif enddo print * #endif 99 format(12f7.0) 98 format(20f7.0) 97 format(16f7.0) 96 format(14f7.0) endif iprintnow=iprintnow+1 if (iprintnow.gt.(np*mp-1)) goto 103 goto 77 103 continue stop return end C++++++++++++++++++++++++++++++++++++++= subroutine test include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,n0=10,l0=l) parameter (n1=nprocx*n0,m1=nprocy*n0) create model variables dimension u(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension u2(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension ulr(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension ubt(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension x(1-ior-ihlag:n0+ior+ihlag, 1-ior-ihlag:n0+ior+ihlag, . 1-ior:l0+ior) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check compute some relevant constants constants for computational grid print *,'Start Test' #if (POLES == 1) do i=1,n1 C ia=i+(npos-1)*np C ip(i)=mod(ia+n1/2-1,n1)+1 COLD ip(i)=mod(i+(n-2)/2-1,n-2)+1 ip(i)=mod(i +n1/2-1,n1)+1 enddo #endif do k=1,l0 do j=1,10 do i=1,10 u(i,j,k)=-k u2(i,j,k)=-k ulr(i,j,k)=-k ubt(i,j,k)=-k x(i,j,k)=-k enddo enddo enddo do j=1,10 do i=1,10 u(i,j,1)=(mype*100+(j-1)*10+i)*1. u2(i,j,1)=(mype*100+(j-1)*10+i)*1. ulr(i,j,1)=(mype*100+(j-1)*10+i)*1. ubt(i,j,1)=(mype*100+(j-1)*10+i)*1. x(i,j,1)=(mype*100+(j-1)*10+i)*1. enddo enddo #if (PARALLEL == 1) call mybarrier() #endif call update(u,n0,n0,l0,n0,n0,ih) call update2(u2,n0,n0,l0,n0,n0,ih) call updatelr(ulr,n0,n0,l0,n0,n0,ih) call updatebt(ubt,n0,n0,l0,n0,n0,ih) #if (SEMILAG == 1) call updatelagr(x,n0,n0,l0,n0,n0,ihlag) #endif #if (PARALLEL == 1) call mybarrier() #endif iprintnow=0 77 continue #if (PARALLEL == 1) call mybarrier() #endif if (mype.eq.iprintnow) then print *,'update mype =',mype do j=n0+ih,1-ih,-1 print 99,u(-2,j,1),u(-1,j,1),u(0,j,1),u(1,j,1),u(2,j,1), . u(3,j,1),u(4,j,1),u(5,j,1),u(6,j,1),u(7,j,1), . u(8,j,1),u(9,j,1),u(10,j,1),u(11,j,1),u(12,j,1), . u(13,j,1) enddo print * print *,'update2 mype =',mype do j=n0+ih,1-ih,-1 print 99,u2(-2,j,1),u2(-1,j,1),u2(0,j,1),u2(1,j,1),u2(2,j,1), . u2(3,j,1),u2(4,j,1),u2(5,j,1),u2(6,j,1),u2(7,j,1), . u2(8,j,1),u2(9,j,1),u2(10,j,1),u2(11,j,1),u2(12,j,1), . u2(13,j,1) enddo print * print *,'updatelr mype =',mype do j=n0+ih,1-ih,-1 print 99,ulr(-2,j,1),ulr(-1,j,1),ulr(0,j,1),ulr(1,j,1),ulr(2,j,1), . ulr(3,j,1),ulr(4,j,1),ulr(5,j,1),ulr(6,j,1),ulr(7,j,1), . ulr(8,j,1),ulr(9,j,1),ulr(10,j,1),ulr(11,j,1),ulr(12,j,1), . ulr(13,j,1) enddo print * print *,'updatebt mype =',mype do j=n0+ih,1-ih,-1 print 99,ubt(-2,j,1),ubt(-1,j,1),ubt(0,j,1),ubt(1,j,1),ubt(2,j,1), . ubt(3,j,1),ubt(4,j,1),ubt(5,j,1),ubt(6,j,1),ubt(7,j,1), . ubt(8,j,1),ubt(9,j,1),ubt(10,j,1),ubt(11,j,1),ubt(12,j,1), . ubt(13,j,1) enddo print * #if (SEMILAG == 1) print *,'updatelgr mype =',mype do j=n0+ihlag+ior,1-ihlag-ior,-1 print 98,x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1),x(1,j,1),x(2,j,1), . x(3,j,1),x(4,j,1),x(5,j,1),x(6,j,1),x(7,j,1), . x(8,j,1),x(9,j,1),x(10,j,1),x(11,j,1),x(12,j,1), . x(13,j,1),x(14,j,1) enddo print * #endif 99 format(16f5.0) 98 format(18f5.0) endif iprintnow=iprintnow+1 if (iprintnow.gt.0) goto 103 goto 77 103 continue #if (PARALLEL == 1) call mybarrier() #endif us=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) c print *,'my_pe:',mype,' max:',um,' min:',un,' sum:',us do i=1,10 do j=1,10 u(i,j,1)=u(i,j,1)-um u(i,j,1)=u(i,j,1)*10e-2 u(i,j,1)=u(i,j,1)**8 enddo enddo #if (PARALLEL == 1) call mybarrier() #endif us1=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um1=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un1=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) do i=1,10 do j=1,10 u(i,j,1)=u(i,j,1)*(-1.) enddo enddo #if (PARALLEL == 1) call mybarrier() #endif us2=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um2=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un2=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) print *,'my_pe:',mype,' M:',um1,' N:',un1,' S:',us1 print *,'my_pe:',mype,' M:',um2,' N:',un2,' S:',us2 stop return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O S U B R O U T I N E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O XAVERAGES (ZONAL AVERAGES) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c---------------------------------------------------------- c parameters used to define different fields for xaverage c---------------------------------------------------------- blockdata blio c---------------------------------------------------------- c parameters used to define different slices c---------------------------------------------------------- common /isflagxz/ iuvsxz,ivvsxz,iwvsxz,ioxsxz,ioysxz,iozsxz, . irhsxz,ithsxz,iprsxz,idvsxz,ikmsxz,ichsxz, . iqvsxz,iqcsxz,iqrsxz,iqasxz,iqbsxz common /isflagyz/ iuvsyz,ivvsyz,iwvsyz,ioxsyz,ioysyz,iozsyz, . irhsyz,ithsyz,iprsyz,idvsyz,ikmsyz,ichsyz, . iqvsyz,iqcsyz,iqrsyz,iqasyz,iqbsyz common /isflagxy/ iuvsxy,ivvsxy,iwvsxy,ioxsxy,ioysxy,iozsxy, . irhsxy,ithsxy,iprsxy,idvsxy,ikmsxy,ichsxy, . iqvsxy,iqcsxy,iqrsxy,iqasxy,iqbsxy c---------------------------------------------------------- data iuvsxz,iuvsyz,iuvsxy / 1, 1, 1 / ! data ivvsxz,ivvsyz,ivvsxy / 1, 1, 1 / ! data iwvsxz,iwvsyz,iwvsxy / 1, 1, 1 / ! data ioxsxz,ioxsyz,ioxsxy / 1, 1, 1 / ! data ioysxz,ioysyz,ioysxy / 1, 1, 1 / ! data iozsxz,iozsyz,iozsxy / 1, 1, 1 / ! data ithsxz,ithsyz,ithsxy / 1, 1, 1 / ! data iprsxz,iprsyz,iprsxy / 1, 1, 1 / ! data idvsxz,idvsyz,idvsxy / 0, 0, 0 / ! data irhsxz,irhsyz,irhsxy / 0, 0, 0 / ! data ikmsxz,ikmsyz,ikmsxy / 0, 0, 0 / ! data iqvsxz,iqvsyz,iqvsxy / 0, 0, 0 / ! data iqcsxz,iqcsyz,iqcsxy / 0, 0, 0 / ! data iqrsxz,iqrsyz,iqrsxy / 0, 0, 0 / ! data iqasxz,iqasyz,iqasxy / 0, 0, 0 / ! data iqbsxz,iqbsyz,iqbsxy / 0, 0, 0 / ! data ichsxz,ichsyz,ichsxy / 0, 0, 0 / ! common /xavflag/ iuxav,ivxav,iwxav,itxav,ipxav, . iu2xav,iv2xav,iw2xav,irwvxav, . irwuxav,irvuxav,irhoxav,itwxav, . ioxxav,ioyxav,iozxav, . iox2xav,ioy2xav,ioz2xav, . ibxxav,ibyxav,ibzxav, . ibx2xav,iby2xav,ibz2xav, . ibzbyxav,ibzbxxav,ibxbyxav data iuxav,ivxav,iwxav,itxav,ipxav / 1, 1, 1, 1, 1/ ! data iu2xav,iv2xav,iw2xav,itwxav / 1, 1, 1, 1/ ! data irwvxav,irwuxav,irvuxav,irhoxav /1, 1, 1, 1/ ! data ioxxav,ioyxav,iozxav / 1, 1, 1/ ! data iox2xav,ioy2xav,ioz2xav / 1, 1, 1/ ! data ibxxav,ibyxav,ibzxav /1, 1, 1/ data ibx2xav,iby2xav,ibz2xav /1, 1, 1/ data ibzbyxav,ibzbxxav,ibxbyxav /1, 1, 1/ end subroutine xaver(u,v,w,ox,oy,oz,bx,by,bz,th,p,tau,iflg) include 'param.nml' include 'msg.inc' logical :: file_exists dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l), . w2(1-ih:np+ih, 1-ih:mp+ih, l), . ox2(1-ih:np+ih, 1-ih:mp+ih, l), . oy2(1-ih:np+ih, 1-ih:mp+ih, l), . oz2(1-ih:np+ih, 1-ih:mp+ih, l), . rwv(1-ih:np+ih, 1-ih:mp+ih, l), . rwu(1-ih:np+ih, 1-ih:mp+ih, l), . rvu(1-ih:np+ih, 1-ih:mp+ih, l), . thw(1-ih:np+ih, 1-ih:mp+ih, l) dimension bx(1-ih:np+ih, 1-ih:mp+ih, l), . by(1-ih:np+ih, 1-ih:mp+ih, l), . bz(1-ih:np+ih, 1-ih:mp+ih, l), . bx2(1-ih:np+ih, 1-ih:mp+ih, l), . by2(1-ih:np+ih, 1-ih:mp+ih, l), . bz2(1-ih:np+ih, 1-ih:mp+ih, l), . bzby(1-ih:np+ih, 1-ih:mp+ih, l), . bzbx(1-ih:np+ih, 1-ih:mp+ih, l), . bxby(1-ih:np+ih, 1-ih:mp+ih, l) dimension arrayyz(m,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common /xavflag/ iuxav,ivxav,iwxav,itxav,ipxav, . iu2xav,iv2xav,iw2xav,irwvxav, . irwuxav,irvuxav,irhoxav,itwxav, . ioxxav,ioyxav,iozxav, . iox2xav,ioy2xav,ioz2xav, . ibxxav,ibyxav,ibzxav, . ibx2xav,iby2xav,ibz2xav, . ibzbyxav,ibzbxxav,ibxbyxav #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif if (iflg.eq.0) then call reduce_sum(th0,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(rho,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(the,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(ue,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(ve,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) endif !computing reynold stresses components do k=1,l do j=1,mp do i=1,np u2(i,j,k)=u(i,j,k)**2 v2(i,j,k)=v(i,j,k)**2 w2(i,j,k)=w(i,j,k)**2 ox2(i,j,k)=ox(i,j,k)**2 oy2(i,j,k)=oy(i,j,k)**2 oz2(i,j,k)=oz(i,j,k)**2 rwv(i,j,k)=rho(i,j,k)*oz(i,j,k)*v(i,j,k) rwu(i,j,k)=rho(i,j,k)*oz(i,j,k)*u(i,j,k) rvu(i,j,k)=rho(i,j,k)*oy(i,j,k)*u(i,j,k) bx2(i,j,k)=bx(i,j,k)**2 by2(i,j,k)=by(i,j,k)**2 bz2(i,j,k)=bz(i,j,k)**2 bzby(i,j,k)=bz(i,j,k)*by(i,j,k) bzbx(i,j,k)=bz(i,j,k)*bx(i,j,k) bxby(i,j,k)=bx(i,j,k)*by(i,j,k) thw(i,j,k)=th(i,j,k)*w(i,j,k) end do end do end do if (iflg.eq.0.and.irst.eq.0) then if(mype.eq.0) then inquire(FILE="xaverages.dat", exist=file_exists) if(file_exists) then print *, 'FILE xaverages.dat EXISTS = ',file_exists open(1,file="xaverages.dat") close(1,status='delete') endif inquire(FILE="fluxav.dat", exist=file_exists) if(file_exists) then print *, 'FILE fluxav.dat EXISTS = ',file_exists open(1,file="fluxav.dat") close(1,status='delete') endif endif else ! HERE SHOULD BE WRITTEN THE QUANTITIES TO AVERAGE if (itwxav.eq.1) call reduce_sum(thw,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iuxav.eq.1) call reduce_sum(u,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ivxav.eq.1) call reduce_sum(v,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iwxav.eq.1) call reduce_sum(w,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioxxav.eq.1) call reduce_sum(ox,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioyxav.eq.1) call reduce_sum(oy,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iozxav.eq.1) call reduce_sum(oz,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iu2xav.eq.1) call reduce_sum(u2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iv2xav.eq.1) call reduce_sum(v2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iw2xav.eq.1) call reduce_sum(w2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iox2xav.eq.1) call reduce_sum(ox2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioy2xav.eq.1) call reduce_sum(oy2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioz2xav.eq.1) call reduce_sum(oz2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irwvxav.eq.1) call reduce_sum(rwv,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irwuxav.eq.1) call reduce_sum(rwu,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irvuxav.eq.1) call reduce_sum(rvu,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibxxav.eq.1) call reduce_sum(bx,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibyxav.eq.1) call reduce_sum(by,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzxav.eq.1) call reduce_sum(bz,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibx2xav.eq.1) call reduce_sum(bx2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iby2xav.eq.1) call reduce_sum(by2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibz2xav.eq.1) call reduce_sum(bz2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzbyxav.eq.1) call reduce_sum(bzby,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzbxxav.eq.1) call reduce_sum(bzbx,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibxbyxav.eq.1) call reduce_sum(bxby,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ipxav.eq.1) call reduce_sum(p,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (itxav.eq.1) call reduce_sum(th,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) end if return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_fluxav(fyz,it) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="fluxav.dat",form='unformatted', & position='append') write(1), fyz,it close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_xaver(fyz,it) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="xaverages.dat",form='unformatted', & position='append') write(1), fyz,it close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_bcprofl(fyz) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="bcprofl.dat",form='unformatted', & position='append') write(1), fyz close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine iorsh(u,v,w,t,p,bx,by,bz,icomm) !mod iosh C--------------------------------------------------------------------- C icomm=1 -> read data from tape and put its values to local array C icomm=0 -> read data from tape and do nothing, this allow to skip C to the proper record on the tape during the next read attempt C C The other method is to direct specify the initial record C on the tape from which the data have to be read. C--------------------------------------------------------------------- include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) if (mype.eq.0) then call ioreadsh0(u,v,w,t,p,bx,by,bz,icomm) !mod iosh else call ioreadshk(u,v,w,t,p,bx,by,bz,icomm) !mod iosh end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O S L I C E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine slices(u,v,w,ox,oy,oz,th,p,tke, * chm,qv,qc,qr,qia,qib,iflg) include "param.nml" include "msg.inc" parameter (ispecial=1) parameter (ixz=1, msl=1, inzxz=1) ! XZ slices parameter (iyz=1, nsl=1, inzyz=1) ! YZ slices parameter (ixy=1, lsl=4, inzxy=1) ! XY slices dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . tke(1-ih:nkep+ih, 1-ih:mkep+ih, lke), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension arrayxy(np,mp),iindx(nsl),jindx(msl),kindx(lsl) dimension fisum(n),fjsum(m) dimension findx(n),fjndx(m) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/realtp/ zsib(1-ih:nibp+ih,1-ih:mibp+ih,lib), . zsib2(1-ih:nibp+ih,1-ih:mibp+ih),tsibi common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/chmind/ i1vh,j1vh,i2vh,j2vh,i3vh,j3vh common /ioflags2/ itops common /isflagxz/ iuvsxz,ivvsxz,iwvsxz,ioxsxz,ioysxz,iozsxz, . irhsxz,ithsxz,iprsxz,idvsxz,ikmsxz,ichsxz, . iqvsxz,iqcsxz,iqrsxz,iqasxz,iqbsxz common /isflagyz/ iuvsyz,ivvsyz,iwvsyz,ioxsyz,ioysyz,iozsyz, . irhsyz,ithsyz,iprsyz,idvsyz,ikmsyz,ichsyz, . iqvsyz,iqcsyz,iqrsyz,iqasyz,iqbsyz common /isflagxy/ iuvsxy,ivvsxy,iwvsxy,ioxsxy,ioysxy,iozsxy, . irhsxy,ithsxy,iprsxy,idvsxy,ikmsxy,ichsxy, . iqvsxy,iqcsxy,iqrsxy,iqasxy,iqbsxy common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/tkeprfl/ tkeprf(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv) #if(NETCDFO == 2) #include "pnetcdf.inc" #include "msg.lnk" integer(KIND=MPI_OFFSET_KIND) ifrmask character(len=8) chname integer cmode #endif ispec=ispecial iprint=0 if(iflg.eq.0) then if(mype.eq.0) print *,'INITIALIZE SLICE OUTPUT' if(ismode.eq.0) then if(mype.eq.0) then if(ixz.eq.1) write(31) n,m,l,lch,nspc,lms,lic,msl if(iyz.eq.1) write(32) n,m,l,lch,nspc,lms,lic,nsl if(ixy.eq.1) write(33) n,m,l,lch,nspc,lms,lic,lsl endif else #if(NETCDFO == 2) cmode=NF_WRITE+NF_64BIT_OFFSET if(ixz.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'xzslc.nc', . cmode, MPI_INFO_NULL, nfhdxz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create xzslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdxz) endif if(iyz.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'yzslc.nc', . cmode, MPI_INFO_NULL, nfhdyz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create yzslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdyz) endif if(ixy.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'xyslc.nc', . cmode, MPI_INFO_NULL, nfhdxy) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create xyslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdxy) endif #endif endif endif ! iflg = 0 create files do k=1,l zcr(k)=(k-1)*dz enddo #if (IMRSB == 0) do j=1,mp do i=1,np arrayxy(i,j)=zs(i,j) enddo enddo #else do j=1,mp do i=1,np arrayxy(i,j)=zsib2(i,j) enddo enddo #endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! slices over topography !-------------------------------------------------- if(ispec.eq.2) then amp=0. do j=1,mp do i=1,np amp=max(amp,arrayxy(i,j)) enddo enddo amp=globmax(amp,1,1,1,1,1,1,1,1,1,1,1,1) if(amp.gt.0) then !-------------------------------------------------- ! find location of max topography amplitude !-------------------------------------------------- fimax=0. fjmax=0. do j=1,mp ja=(mpos-1)*mp + j do i=1,np ia=(npos-1)*np + i if(amp.eq.arrayxy(i,j)) then fimax=float(ia) fjmax=float(ja) endif enddo enddo fimax=globmax(fimax,1,1,1,1,1,1,1,1,1,1,1,1) fjmax=globmax(fjmax,1,1,1,1,1,1,1,1,1,1,1,1) imax=fimax jmax=fjmax !---------------------------------------------------- ! find location of max averaged topography amplitude !---------------------------------------------------- do i=1,n fisum(i)=0. findx(i)=0. enddo do j=1,m fjsum(j)=0. fjndx(j)=0. enddo do i=1,np ia=(npos-1)*np + i fisum(ia)=0. findx(ia)=0. do j=1,mp if(arrayxy(i,j).gt.0.) then fisum(ia)=fisum(ia)+arrayxy(i,j) findx(ia)=findx(ia)+1. endif enddo enddo fisumg=0. iindxg=0 do i=1,n findx(i)=globsum(findx(i),1,1,1,1,1,1,1,1,1,1,1,1) fisum(i)=globsum(fisum(i),1,1,1,1,1,1,1,1,1,1,1,1)/findx(i) fisumg=max(fisumg,fisum(i)) if(fisum(i).eq.fisumg) iindxg=i enddo do j=1,mp ja=(mpos-1)*mp + j fjsum(ja)=0. fjndx(ja)=0. do i=1,np if(arrayxy(i,j).gt.0.) then fjsum(ja)=fjsum(ja)+arrayxy(i,j) fjndx(ja)=fjndx(ja)+1. endif enddo enddo fjsumg=0. jindxg=0 do j=1,n fjndx(j)=globsum(fjndx(j),1,1,1,1,1,1,1,1,1,1,1,1) fjsum(j)=globsum(fjsum(j),1,1,1,1,1,1,1,1,1,1,1,1)/fjndx(j) fjsumg=max(fjsumg,fjsum(j)) if(fjsum(j).eq.fjsumg) jindxg=j enddo iindx(1)=(n-1)/2+1 ! center of the domain iindx(2)=iindxg ! max topography iindx(3)=imax ! max average of topography jindx(1)=(m-j3)/2+1 ! center of the domain jindx(2)=jindxg ! max topography jindx(3)=jmax ! max average of topography kindx(1)=1 kindx(2)=2 kindx(3)=3 kindx(4)=4 kindx(5)=5 kindx(6)=min(nint((amp*0.35)/dz+1.),l) kindx(7)=min(nint((amp*0.50)/dz+1.),l) else ! iamp == 0 ispec=0 endif ! iamp endif ! ispec = 2 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! define slices by hand !-------------------------------------------------- if(ispec.eq.1) then c iindx(1)=i1vh c iindx(2)=i2vh c iindx(3)=i3vh iindx(1)=n/2 c jindx(1)=j1vh c jindx(2)=j2vh c jindx(3)=j3vh jindx(1)=m/2 c kindx(1)=1 c kindx(2)=min(nint((zb*0.10)/dz+1.),l) c kindx(3)=min(nint((zb*0.25)/dz+1.),l) c kindx(4)=min(nint((zb*0.35)/dz+1.),l) c kindx(5)=min(nint((zb*0.50)/dz+1.),l) c kindx(6)=min(nint((zb*0.75)/dz+1.),l) c kindx(7)=min(nint((zb*1.00)/dz+1.),l) kindx(1)=min(nint((zb*0.35)/dz+1.),l) kindx(2)=min(nint((zb*0.50)/dz+1.),l) kindx(3)=min(nint((zb*0.75)/dz+1.),l) kindx(4)=min(nint((zb*0.95)/dz+1.),l) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! semi-default automatic configuration !-------------------------------------------------- if(ispec.eq.0) then do ii=1,nsl iindx(ii)=max(min((n-1)*ii/(nsl+1)+1,n),1) if(mype.eq.0) print *,'iindx:',ii,iindx(ii) enddo do jj=1,msl jindx(jj)=max(min((m-j3)*jj/(msl+1)+1,m),1) if(mype.eq.0) print *,'jindx:',jj,jindx(jj) enddo do kk=2,lsl-1 kindx(kk)=max(min((l-1)*kk/(lsl+1)+1,l),1) if(mype.eq.0) print *,'kindx:',kk,kindx(kk) enddo kindx(1 )=1 kindx(lsl)=l endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! vertical xz slices ! --------------------------------- if(ixz.eq.1) then inr=31 inz=inzxz if(mype.eq.0) print *,'WRITE XZ SLICE OUTPUT',iflg,jindx if(ismode.eq.0) then if(mype.eq.0) write(inr) jindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'xzslc.nc', . NF_READ, MPI_INFO_NULL, nfhdxz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc open stat ',nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdxz,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc inq unlim dim ',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdxz,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc inq dimlen ',nfmpi_strerror(ier) ifraxz=ifrmask+1 ier=nfmpi_close(nfhdxz) else ifraxz=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','xzslc.nc',13,1,1,1,ifraxz,zs) #else call pnet_out_chunk('zs ','xzslc.nc',13,1,1,1,ifraxz,zsib) #endif #endif endif ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do jsl=1,msl if(ismode.eq.0) then if(iuvsxz.eq.1) call writeslxz(u ,zcr,inz,jindx(jsl),1,inr) if(ivvsxz.eq.1) call writeslxz(v ,zcr,inz,jindx(jsl),2,inr) if(iwvsxz.eq.1) call writeslxz(w ,zcr,inz,jindx(jsl),3,inr) if(ioxsxz.eq.1) call writeslxz(ox ,zcr,inz,jindx(jsl),4,inr) if(ioysxz.eq.1) call writeslxz(oy ,zcr,inz,jindx(jsl),5,inr) if(iozsxz.eq.1) call writeslxz(oz ,zcr,inz,jindx(jsl),6,inr) if(ithsxz.eq.1) call writeslxz(th ,zcr,inz,jindx(jsl),7,inr) if(iprsxz.eq.1) call writeslxz(p ,zcr,inz,jindx(jsl),8,inr) if(irhsxz.eq.1) call writeslxz(rho,zcr,inz,jindx(jsl),9,inr) if(ikesxz.eq.1) call writeslxz(tke,zcr,inz,jindx(jsl),10,inr) else #if(NETCDFO == 2) if(iuvsxz.eq.1) call pnet_out_chunk . ('u_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,u) if(ivvsxz.eq.1) call pnet_out_chunk . ('v_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,v) if(iwvsxz.eq.1) call pnet_out_chunk . ('w_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,w) if(ioxsxz.eq.1) call pnet_out_chunk . ('ox_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,ox) if(ioysxz.eq.1) call pnet_out_chunk . ('oy_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,oy) if(iozsxz.eq.1) call pnet_out_chunk . ('oz_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,oz) if(ithsxz.eq.1) call pnet_out_chunk . ('th_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,th) if(iprsxz.eq.1) call pnet_out_chunk . ('pr_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,p) if(irhsxz.eq.1) call pnet_out_chunk . ('rh_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,rho) if(ikesxz.eq.1) call pnet_out_chunk . ('ke_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsxz.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslxz(chm(1-ih,1-ih,1,ispc),zcr,inz,jindx(jsl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'xzslc.nc',11,1,jindx(jsl),1,ifraxz,chm(1-ih,1-ih,1,ispc)) #endif endif enddo endif if(lms.gt.1) then if(ismode.eq.0) then if(iqvsxz.eq.1) call writeslxz(qv ,zcr,inz,jindx(jsl),12,inr) if(iqcsxz.eq.1) call writeslxz(qc ,zcr,inz,jindx(jsl),13,inr) if(iqrsxz.eq.1) call writeslxz(qr ,zcr,inz,jindx(jsl),14,inr) else #if(NETCDFO == 2) if(iqvsxz.eq.1) call pnet_out_chunk . ('qvxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qv) if(iqcsxz.eq.1) call pnet_out_chunk . ('qcxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qc) if(iqrsxz.eq.1) call pnet_out_chunk . ('qrxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qr) #endif endif !ismode endif !lms if(lic.gt.1) then if(ismode.eq.0) then if(iqasxz.eq.1) call writeslxz(qia,zcr,inz,jindx(jsl),15,inr) if(iqbsxz.eq.1) call writeslxz(qib,zcr,inz,jindx(jsl),16,inr) else #if(NETCDFO == 2) if(iqasxz.eq.1) call pnet_out_chunk . ('qiaxzcro','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qia) if(iqbsxz.eq.1) call pnet_out_chunk . ('qibxzcro','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qib) #endif endif !ismode endif !lic enddo if(mype.eq.0) print *,'WRITE XZ SLICE OUTPUT DONE' endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! vertical yz slices ! --------------------------------- if(iyz.eq.1) then inr=32 inz=inzyz if(mype.eq.0) print *,'WRITE YZ SLICE OUTPUT',iflg,iindx if(ismode.eq.0) then if(mype.eq.0) write(inr) iindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'yzslc.nc', . NF_READ, MPI_INFO_NULL, nfhdyz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc open stat ', . nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdyz,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc inq unlim dim',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdyz,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc inq dimlen',nfmpi_strerror(ier) ifrayz=ifrmask+1 ier=nfmpi_close(nfhdyz) else ifrayz=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','yzslc.nc',13,1,1,1,ifrayz,zs) #else call pnet_out_chunk('zs ','yzslc.nc',13,1,1,1,ifrayz,zsib) #endif #endif endif ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do isl=1,nsl if(ismode.eq.0) then if(iuvsyz.eq.1) call writeslyz(u ,zcr,inz,iindx(isl),1,inr) if(ivvsyz.eq.1) call writeslyz(v ,zcr,inz,iindx(isl),2,inr) if(iwvsyz.eq.1) call writeslyz(w ,zcr,inz,iindx(isl),3,inr) if(ioxsyz.eq.1) call writeslyz(ox ,zcr,inz,iindx(isl),4,inr) if(ioysyz.eq.1) call writeslyz(oy ,zcr,inz,iindx(isl),5,inr) if(iozsyz.eq.1) call writeslyz(oz ,zcr,inz,iindx(isl),6,inr) if(ithsyz.eq.1) call writeslyz(th ,zcr,inz,iindx(isl),7,inr) if(iprsyz.eq.1) call writeslyz(p ,zcr,inz,iindx(isl),8,inr) if(irhsyz.eq.1) call writeslyz(rho,zcr,inz,iindx(isl),9,inr) if(ikesyz.eq.1) call writeslyz(tke,zcr,inz,iindx(isl),10,inr) else #if(NETCDFO == 2) if(iuvsyz.eq.1) call pnet_out_chunk . ('u_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,u) if(ivvsyz.eq.1) call pnet_out_chunk . ('v_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,v) if(iwvsyz.eq.1) call pnet_out_chunk . ('w_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,w) if(ioxsyz.eq.1) call pnet_out_chunk . ('ox_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,ox) if(ioysyz.eq.1) call pnet_out_chunk . ('oy_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,oy) if(iozsyz.eq.1) call pnet_out_chunk . ('oz_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,oz) if(ithsyz.eq.1) call pnet_out_chunk . ('th_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,th) if(iprsyz.eq.1) call pnet_out_chunk . ('pr_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,p) if(irhsyz.eq.1) call pnet_out_chunk . ('rh_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,rho) if(ikesyz.eq.1) call pnet_out_chunk . ('ke_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsyz.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslyz(chm(1-ih,1-ih,1,ispc),zcr,inz,iindx(isl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'yzslc.nc',12,iindx(isl),1,1,ifrayz,chm(1-ih,1-ih,1,ispc)) #endif endif enddo endif if(lms.gt.1) then if(ismode.eq.0) then if(iqvsyz.eq.1) call writeslyz(qv ,zcr,inz,iindx(isl),12,inr) if(iqcsyz.eq.1) call writeslyz(qc ,zcr,inz,iindx(isl),13,inr) if(iqrsyz.eq.1) call writeslyz(qr ,zcr,inz,iindx(isl),14,inr) else #if(NETCDFO == 2) if(iqvsyz.eq.1) call pnet_out_chunk . ('qvcrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qv) if(iqcsyz.eq.1) call pnet_out_chunk . ('qccrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qc) if(iqrsyz.eq.1) call pnet_out_chunk . ('qrcrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qr) #endif endif !ismode endif if(lic.gt.1) then if(ismode.eq.0) then if(iqasyz.eq.1) call writeslyz(qia,zcr,inz,iindx(isl),15,inr) if(iqbsyz.eq.1) call writeslyz(qib,zcr,inz,iindx(isl),16,inr) else #if(NETCDFO == 2) if(iqasyz.eq.1) call pnet_out_chunk . ('qiacroyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qia) if(iqbsyz.eq.1) call pnet_out_chunk . ('qibcroyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qib) #endif endif !ismode endif enddo if(mype.eq.0) print *,'WRITE YZ SLICE OUTPUT DONE' endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! horixontal xy slices ! --------------------------------- if(ixy.eq.1) then inr=33 inz=inzxy if(mype.eq.0) print *,'WRITE XY SLICE OUTPUT',iflg,kindx if(ismode.eq.0) then if(mype.eq.0) write(inr) kindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'xyslc.nc', . NF_READ, MPI_INFO_NULL, nfhdxy) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc open stat ', . nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdxy,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc inq unlim dim ',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdxy,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc inq dimlen ',nfmpi_strerror(ier) ifraxy=ifrmask+1 ier=nfmpi_close(nfhdxy) else ifraxy=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','xyslc.nc',13,1,1,1,ifraxy,zs) #else call pnet_out_chunk('zs ','xyslc.nc',13,1,1,1,ifraxy,zsib) #endif #endif endif !ismode ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do ksl=1,lsl if(ismode.eq.0) then if(iuvsxy.eq.1) call writeslxy(u ,zcr,inz,kindx(ksl),1,inr) if(ivvsxy.eq.1) call writeslxy(v ,zcr,inz,kindx(ksl),2,inr) if(iwvsxy.eq.1) call writeslxy(w ,zcr,inz,kindx(ksl),3,inr) if(ioxsxy.eq.1) call writeslxy(ox ,zcr,inz,kindx(ksl),4,inr) if(ioysxy.eq.1) call writeslxy(oy ,zcr,inz,kindx(ksl),5,inr) if(iozsxy.eq.1) call writeslxy(oz ,zcr,inz,kindx(ksl),6,inr) if(ithsxy.eq.1) call writeslxy(th ,zcr,inz,kindx(ksl),7,inr) if(iprsxy.eq.1) call writeslxy(p ,zcr,inz,kindx(ksl),8,inr) if(irhsxy.eq.1) call writeslxy(rho,zcr,inz,kindx(ksl),9,inr) if(ikesxy.eq.1) call writeslxy(tke,zcr,inz,kindx(ksl),10,inr) else #if(NETCDFO == 2) if(iuvsxy.eq.1) call pnet_out_chunk . ('u_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,u) if(ivvsxy.eq.1) call pnet_out_chunk . ('v_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,v) if(iwvsxy.eq.1) call pnet_out_chunk . ('w_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,w) if(ioxsxy.eq.1) call pnet_out_chunk . ('ox_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,ox) if(ioysxy.eq.1) call pnet_out_chunk . ('oy_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,oy) if(iozsxy.eq.1) call pnet_out_chunk . ('oz_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,oz) if(ithsxy.eq.1) call pnet_out_chunk . ('th_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,th) if(iprsxy.eq.1) call pnet_out_chunk . ('pr_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,p) if(irhsxy.eq.1) call pnet_out_chunk . ('rh_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,rho) if(ikesxy.eq.1) call pnet_out_chunk . ('ke_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsxy.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslxy(chm(1-ih,1-ih,1,ispc),zcr,inz,kindx(ksl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'xyslc.nc',10,1,1,kindx(ksl),ifraxy,chm(1-ih,1-ih,1,ispc)) #endif endif !ismode enddo endif !lch if(lms.gt.1) then if(ismode.eq.0) then if(iqvsxy.eq.1) call writeslxy(qv ,zcr,inz,kindx(ksl),12,inr) if(iqcsxy.eq.1) call writeslxy(qc ,zcr,inz,kindx(ksl),13,inr) if(iqrsxy.eq.1) call writeslxy(qr ,zcr,inz,kindx(ksl),14,inr) else #if(NETCDFO == 2) if(iqvsxy.eq.1) call pnet_out_chunk . ('qv_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qv) if(iqcsxy.eq.1) call pnet_out_chunk . ('qc_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qc) if(iqrsxy.eq.1) call pnet_out_chunk . ('qr_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qr) #endif endif !ismode endif !lms if(lic.gt.1) then if(ismode.eq.0) then if(iqasxy.eq.1) call writeslxy(qia,zcr,inz,kindx(ksl),15,inr) if(iqbsxy.eq.1) call writeslxy(qib,zcr,inz,kindx(ksl),16,inr) else #if(NETCDFO == 2) if(iqasxy.eq.1) call pnet_out_chunk . ('qia_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qia) if(iqbsxy.eq.1) call pnet_out_chunk . ('qib_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qib) #endif endif !ismode endif !lic enddo if(mype.eq.0) print *,'WRITE XY SLICE OUTPUT DONE' endif return end !------------------------------------------------------------- subroutine writeslxz(f,zcr,inz,jslice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayxz(np,l),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 icomp=0 do j=1,mp ja=(mpos-1)*mp + j if(ja.eq.jslice) then icomp=1 jloc=j endif enddo if(icomp.eq.1) then if(inz.eq.1) then do k=l,1,-1 do i=1,np zbr=(zcr(k)-zs(i,jloc))*gi(i,jloc) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayxz(i,k)=f(i,jloc,k1)+(f(i,jloc,k2)-f(i,jloc,k1))*fz else arrayxz(i,k)=f(i,jloc,k2) endif enddo enddo else do k=1,l do i=1,np arrayxz(i,k)=f(i,jloc,k) enddo enddo endif else do k=1,l do i=1,np arrayxz(i,k)=0. enddo enddo endif if (mype.eq.0) then call slicexz0(arrayxz,icomp,inr) else call slicexzk(arrayxz,icomp) end if call mybarrier() return end subroutine slicexz0(arrayxz,icomp,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif dimension arrayxz(np,l) dimension slicexz(n,l) common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz if(icomp.eq.1) then do k=1,l do i=1,np slicexz(i,k)=arrayxz(i,k) end do end do endif #if (PARALLEL > 0) nlp=np*l cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(fcompxz,fcompxz,1 ,iproc) call shmem_get32(tmpxz,tmpxz,nlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(fcompxz,fcompxz,1 ,iproc) call shmem_get64(tmpxz,tmpxz,nlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(fcompxz,fcompxz,1 ,iproc) call shmem_get(tmpxz,tmpxz,nlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, fcompxz, 1 , 1, ierr) call pvmfunpack(REAL8, tmpxz, nlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(fcompxz, 1 , DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) call MPI_Recv(tmpxz, nlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif kcomp=int(fcompxz) if(kcomp.eq.1) then npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do i=1,np slicexz(((npos1-1)*np+i),k)=tmpxz(i,k) end do end do endif end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) slicexz return end subroutine slicexzk(arrayxz,icomp) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxz(np,l) #if (PARALLEL > 0) nlp=np*l cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do k=1,l do i=1,np tmpxz(i,k)=arrayxz(i,k) end do end do call mybarrier() #else fcompxz=float(icomp) call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, fcompxz, 1 , 1, ierr) call pvmfpack(REAL8, arrayxz, nlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) fcompxz=float(icomp) call MPI_Send(fcompxz, 1 , DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) call MPI_Send(arrayxz, nlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end !------------------------------------------------------------- subroutine writeslyz(f,zcr,inz,islice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayyz(mp,l),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 icomp=0 do i=1,np ia=(npos-1)*np + i if(ia.eq.islice) then icomp=1 iloc=i endif enddo if(icomp.eq.1) then if(inz.eq.1) then do k=l,1,-1 do j=1,mp zbr=(zcr(k)-zs(iloc,j))*gi(iloc,j) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayyz(j,k)=f(iloc,j,k1)+(f(iloc,j,k2)-f(iloc,j,k1))*fz else arrayyz(j,k)=f(iloc,j,k2) endif enddo enddo else do k=1,l do j=1,mp arrayyz(j,k)=f(iloc,j,k) enddo enddo endif else do k=1,l do j=1,mp arrayyz(j,k)=0. enddo enddo endif if (mype.eq.0) then call sliceyz0(arrayyz,icomp,inr) else call sliceyzk(arrayyz,icomp) end if call mybarrier() return end subroutine sliceyz0(arrayyz,icomp,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayyz(mp,l) dimension sliceyz(m,l) if(icomp.eq.1) then do k=1,l do j=1,mp sliceyz(j,k)=arrayyz(j,k) end do end do endif #if (PARALLEL > 0) mlp=mp*l cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(fcompyz,fcompyz,1 ,iproc) call shmem_get32(tmpyz,tmpyz,mlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(fcompyz,fcompyz,1 ,iproc) call shmem_get64(tmpyz,tmpyz,mlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(fcompyz,fcompyz,1 ,iproc) call shmem_get(tmpyz,tmpyz,mlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, fcompyz, 1 , 1, ierr) call pvmfunpack(REAL8, tmpyz, mlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(fcompyz, 1 , DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) call MPI_Recv(tmpyz, mlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif kcomp=int(fcompyz) if(kcomp.eq.1) then mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp sliceyz(((mpos1-1)*mp+j),k)=tmpyz(j,k) end do end do endif end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) sliceyz return end subroutine sliceyzk(arrayyz,icomp) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayyz(mp,l) #if (PARALLEL > 0) mlp=mp*l cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do k=1,l do j=1,mp tmpyz(j,k)=arrayyz(j,k) end do end do call mybarrier() #else fcompyz=float(icomp) call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, fcompyz, 1 , 1, ierr) call pvmfpack(REAL8, arrayyz, mlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) fcompyz=float(icomp) call MPI_Send(fcompyz, 1 , DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) call MPI_Send(arrayyz, mlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end !------------------------------------------------------------- subroutine writeslxy(f,zcr,inz,kslice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayxy(np,mp),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 if(inz.eq.1) then do k=l,1,-1 if (k.eq.kslice) then do j=1,mp do i=1,np zbr=(zcr(k)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayxy(i,j)=f(i,j,k1)+(f(i,j,k2)-f(i,j,k1))*fz else arrayxy(i,j)=f(i,j,k2) endif enddo enddo endif enddo else do j=1,mp do i=1,np arrayxy(i,j)=f(i,j,kslice) enddo enddo endif if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() return end subroutine slicexy0(arrayxy,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxy(np,mp) dimension slicexy(n,m) do j=1,mp do i=1,np slicexy(i,j)=arrayxy(i,j) end do end do #if (PARALLEL > 0) nmp=np*mp cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmpxy,tmpxy,nmp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxy,tmpxy,nmp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmpxy,tmpxy,nmp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmpxy, nmp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmpxy, nmp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do j=1,mp do i=1,np slicexy(((npos1-1)*np+i),((mpos1-1)*mp+j))=tmpxy(i,j) end do end do end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) slicexy return end subroutine slicexyk(arrayxy) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxy(np,mp) #if (PARALLEL > 0) nmp=np*mp cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do j=1,mp do i=1,np tmpxy(i,j)=arrayxy(i,j) end do end do call mybarrier() #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, arrayxy, nmp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(arrayxy, nmp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end subroutine iowrsh(u,v,w,t,p,bx,by,bz) !mod iosh include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) if (mype.eq.0) then call iowritesh0(u,v,w,t,p,bx,by,bz) else call iowriteshk(u,v,w,t,p,bx,by,bz) end if return end c mod-restart subroutine ioread(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) if (mype.eq.0) then c mod-restart call ioread0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) else c mod-restart call ioreadk(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) end if return end c mod-restart subroutine iowrite(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) c real hise(nthv,2),hischm(nthv,4) real hise(nthv,2),hischm(nthv,nspc) if (mype.eq.0) then c mod-restart call iowrite0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm, . bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) else c mod-restart call iowritek(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm, . bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine ioreadsh0(u,v,w,t,p,bx,by,bz,icomm) !mod iosh c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif inr=12 ! read from fort.12 ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() call readit0(t,temp,ifullarr,icomm,inr) call mybarrier() call readit0(p,temp,ifullarr,icomm,inr) call mybarrier() if(nmhd.eq.n) then call readit0(bx,temp,1,icomm,inr) call mybarrier() call readit0(by,temp,1,icomm,inr) call mybarrier() call readit0(bz,temp,1,icomm,inr) call mybarrier() else call readit0(bx,temp,0,icomm,inr) call mybarrier() call readit0(by,temp,0,icomm,inr) call mybarrier() call readit0(bz,temp,0,icomm,inr) call mybarrier() endif return end subroutine ioreadshk(u,v,w,t,p,bx,by,bz,icomm) !mod iosh c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() call readitk(t,ifullarr,icomm) call mybarrier() call readitk(p,ifullarr,icomm) call mybarrier() if(nmhd.eq.n) then call readitk(bx,1,icomm) call mybarrier() call readitk(by,1,icomm) call mybarrier() call readitk(bz,1,icomm) call mybarrier() else call readitk(bx,0,icomm) call mybarrier() call readitk(by,0,icomm) call mybarrier() call readitk(bz,0,icomm) call mybarrier() endif return end subroutine iowritesh0(u,v,w,t,p,bx,by,bz) !mod iosh c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) real hise(nthv,2) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time inr=11 ! write to fort.11 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() call writeit0(t,temp,ifullarr,inr) call mybarrier() call writeit0(p,temp,ifullarr,inr) call mybarrier() if(nmhd.eq.n) then call writeit0(bx,temp,1,inr) call mybarrier() call writeit0(by,temp,1,inr) call mybarrier() call writeit0(bz,temp,1,inr) call mybarrier() endif return end subroutine iowriteshk(u,v,w,t,p,bx,by,bz) !mod iosh c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() call writeitk(t,ifullarr) call mybarrier() call writeitk(p,ifullarr) call mybarrier() if(nmhd.eq.n) then call writeitk(bx,1) call mybarrier() call writeitk(by,1) call mybarrier() call writeitk(bz,1) call mybarrier() endif return end c mod-restart subroutine ioread0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif inr=10 ! read from fort.10 ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() call readit0(ox,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oy,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oz,temp,ifullarr,icomm,inr) call mybarrier() c mod-restart call readit0(ox2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oy2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oz2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(th,temp,ifullarr,icomm,inr) call mybarrier() call readit0(p,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fx,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fy,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fz,temp,ifullarr,icomm,inr) call mybarrier() call readit0(ft,temp,ifullarr,icomm,inr) call mybarrier() if (nts.eq.n) then call readit0(fox,temp,1,icomm,inr) call mybarrier() call readit0(foy,temp,1,icomm,inr) call mybarrier() call readit0(foz,temp,1,icomm,inr) call mybarrier() else call readit0(fox,temp,0,icomm,inr) call mybarrier() call readit0(foy,temp,0,icomm,inr) call mybarrier() call readit0(foz,temp,0,icomm,inr) call mybarrier() end if if(nmhd.eq.n) then call readit0(pm,temp,1,icomm,inr) call mybarrier() call readit0(bx,temp,1,icomm,inr) call mybarrier() call readit0(by,temp,1,icomm,inr) call mybarrier() call readit0(bz,temp,1,icomm,inr) call mybarrier() call readit0(fbx,temp,1,icomm,inr) call mybarrier() call readit0(fby,temp,1,icomm,inr) call mybarrier() call readit0(fbz,temp,1,icomm,inr) call mybarrier() c mod-restart call readit0(bx1,temp,1,icomm,inr) call mybarrier() call readit0(by1,temp,1,icomm,inr) call mybarrier() call readit0(bz1,temp,1,icomm,inr) call mybarrier() call readit0(bxe,temp,1,icomm,inr) call mybarrier() call readit0(bye,temp,1,icomm,inr) call mybarrier() call readit0(bze,temp,1,icomm,inr) call mybarrier() else call readit0(pm,temp,0,icomm,inr) call mybarrier() call readit0(bx,temp,0,icomm,inr) call mybarrier() call readit0(by,temp,0,icomm,inr) call mybarrier() call readit0(bz,temp,0,icomm,inr) call mybarrier() call readit0(fbx,temp,0,icomm,inr) call mybarrier() call readit0(fby,temp,0,icomm,inr) call mybarrier() call readit0(fbz,temp,0,icomm,inr) call mybarrier() c mod-restart call readit0(bx1,temp,0,icomm,inr) call mybarrier() call readit0(by1,temp,0,icomm,inr) call mybarrier() call readit0(bz1,temp,0,icomm,inr) call mybarrier() call readit0(bxe,temp,0,icomm,inr) call mybarrier() call readit0(bye,temp,0,icomm,inr) call mybarrier() call readit0(bze,temp,0,icomm,inr) call mybarrier() end if if (nms.eq.n) then call readit0(qv,temp,1,icomm,inr) call mybarrier() call readit0(qc,temp,1,icomm,inr) call mybarrier() call readit0(qr,temp,1,icomm,inr) call mybarrier() call readit0(fqv,temp,1,icomm,inr) call mybarrier() call readit0(fqc,temp,1,icomm,inr) call mybarrier() call readit0(fqr,temp,1,icomm,inr) call mybarrier() else call readit0(qv,temp,0,icomm,inr) call mybarrier() call readit0(qc,temp,0,icomm,inr) call mybarrier() call readit0(qr,temp,0,icomm,inr) call mybarrier() call readit0(fqv,temp,0,icomm,inr) call mybarrier() call readit0(fqc,temp,0,icomm,inr) call mybarrier() call readit0(fqr,temp,0,icomm,inr) call mybarrier() end if if (nicp.eq.n) then call readit0(qia,temp,1,icomm,inr) call mybarrier() call readit0(qib,temp,1,icomm,inr) call mybarrier() call readit0(fqia,temp,1,icomm,inr) call mybarrier() call readit0(fqib,temp,1,icomm,inr) call mybarrier() else call readit0(qia,temp,0,icomm,inr) call mybarrier() call readit0(qib,temp,0,icomm,inr) call mybarrier() call readit0(fqia,temp,0,icomm,inr) call mybarrier() call readit0(fqib,temp,0,icomm,inr) call mybarrier() end if if (nkv.eq.n) then call readit0(tke,temp,1,icomm,inr) call mybarrier() else call readit0(tke,temp,0,icomm,inr) call mybarrier() end if if (nke.eq.n) then call readit0(ftke,temp,1,icomm,inr) call mybarrier() else call readit0(ftke,temp,0,icomm,inr) call mybarrier() end if do jfil=1,nspc call readit0( chm(1-ih,1-ih,1,jfil),temp,ichm,icomm,inr) call mybarrier() enddo do jfil=1,nspc call readit0(fchm(1-ih,1-ih,1,jfil),temp,ichm,icomm,inr) call mybarrier() enddo return end c mod-restart subroutine ioreadk(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() call readitk(ox,ifullarr,icomm) call mybarrier() call readitk(oy,ifullarr,icomm) call mybarrier() call readitk(oz,ifullarr,icomm) call mybarrier() c mod-restart call readitk(ox2,ifullarr,icomm) call mybarrier() call readitk(oy2,ifullarr,icomm) call mybarrier() call readitk(oz2,ifullarr,icomm) call mybarrier() call readitk(th,ifullarr,icomm) call mybarrier() call readitk(p,ifullarr,icomm) call mybarrier() call readitk(fx,ifullarr,icomm) call mybarrier() call readitk(fy,ifullarr,icomm) call mybarrier() call readitk(fz,ifullarr,icomm) call mybarrier() call readitk(ft,ifullarr,icomm) call mybarrier() if (nts.eq.n) then call readitk(fox,1,icomm) call mybarrier() call readitk(foy,1,icomm) call mybarrier() call readitk(foz,1,icomm) call mybarrier() else call readitk(fox,0,icomm) call mybarrier() call readitk(foy,0,icomm) call mybarrier() call readitk(foz,0,icomm) call mybarrier() end if if(nmhd.eq.n) then call readitk(pm,1,icomm) call mybarrier() call readitk(bx,1,icomm) call mybarrier() call readitk(by,1,icomm) call mybarrier() call readitk(bz,1,icomm) call mybarrier() call readitk(fbx,1,icomm) call mybarrier() call readitk(fby,1,icomm) call mybarrier() call readitk(fbz,1,icomm) call mybarrier() c mod-restart call readitk(bx1,1,icomm) call mybarrier() call readitk(by1,1,icomm) call mybarrier() call readitk(bz1,1,icomm) call mybarrier() call readitk(bxe,1,icomm) call mybarrier() call readitk(bye,1,icomm) call mybarrier() call readitk(bze,1,icomm) call mybarrier() else call readitk(pm,0,icomm) call mybarrier() call readitk(bx,0,icomm) call mybarrier() call readitk(by,0,icomm) call mybarrier() call readitk(bz,0,icomm) call mybarrier() call readitk(fbx,0,icomm) call mybarrier() call readitk(fby,0,icomm) call mybarrier() call readitk(fbz,0,icomm) call mybarrier() c mod-restart call readitk(bx1,0,icomm) call mybarrier() call readitk(by1,0,icomm) call mybarrier() call readitk(bz1,0,icomm) call mybarrier() call readitk(bxe,0,icomm) call mybarrier() call readitk(bye,0,icomm) call mybarrier() call readitk(bze,0,icomm) call mybarrier() end if if (nms.eq.n) then call readitk(qv,1,icomm) call mybarrier() call readitk(qc,1,icomm) call mybarrier() call readitk(qr,1,icomm) call mybarrier() call readitk(fqv,1,icomm) call mybarrier() call readitk(fqc,1,icomm) call mybarrier() call readitk(fqr,1,icomm) call mybarrier() else call readitk(qv,0,icomm) call mybarrier() call readitk(qc,0,icomm) call mybarrier() call readitk(qr,0,icomm) call mybarrier() call readitk(fqv,0,icomm) call mybarrier() call readitk(fqc,0,icomm) call mybarrier() call readitk(fqr,0,icomm) call mybarrier() end if if (nicp.eq.n) then call readitk(qia,1,icomm) call mybarrier() call readitk(qib,1,icomm) call mybarrier() call readitk(fqia,1,icomm) call mybarrier() call readitk(fqib,1,icomm) call mybarrier() else call readitk(qia,0,icomm) call mybarrier() call readitk(qib,0,icomm) call mybarrier() call readitk(fqia,0,icomm) call mybarrier() call readitk(fqib,0,icomm) call mybarrier() end if if (nkv.eq.n) then call readitk(tke,1,icomm) call mybarrier() else call readitk(tke,0,icomm) call mybarrier() end if if (nke.eq.n) then call readitk(ftke,1,icomm) call mybarrier() else call readitk(ftke,0,icomm) call mybarrier() end if do jfil=1,nspc call readitk( chm(1-ih,1-ih,1,jfil),ichm,icomm) call mybarrier() enddo do jfil=1,nspc call readitk(fchm(1-ih,1-ih,1,jfil),ichm,icomm) call mybarrier() enddo return end subroutine iovelwrite0(u,v,w,inr) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) integer inr #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time print *,'WRITE VELOCITY at: ',time c inr=19 ! write to fort.19 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() return end subroutine iovelwritek(u,v,w) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() return end subroutine iovelread0(u,v,w,icomm,inr) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() return end subroutine iovelreadk(u,v,w,icomm) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() return end c mod-restart subroutine iowrite0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) real hise(nthv,2),hischm(nthv,4) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time inr=9 ! write to fort.10 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() call writeit0(ox,temp,ifullarr,inr) call mybarrier() call writeit0(oy,temp,ifullarr,inr) call mybarrier() call writeit0(oz,temp,ifullarr,inr) call mybarrier() c mod-restart call writeit0(ox2,temp,ifullarr,inr) call mybarrier() call writeit0(oy2,temp,ifullarr,inr) call mybarrier() call writeit0(oz2,temp,ifullarr,inr) call mybarrier() call writeit0(th,temp,ifullarr,inr) call mybarrier() call writeit0(p,temp,ifullarr,inr) call mybarrier() call writeit0(fx,temp,ifullarr,inr) call mybarrier() call writeit0(fy,temp,ifullarr,inr) call mybarrier() call writeit0(fz,temp,ifullarr,inr) call mybarrier() call writeit0(ft,temp,ifullarr,inr) call mybarrier() if (nts.eq.n) then call writeit0(fox,temp,1,inr) call mybarrier() call writeit0(foy,temp,1,inr) call mybarrier() call writeit0(foz,temp,1,inr) call mybarrier() else call writeit0(fox,temp,0,inr) call mybarrier() call writeit0(foy,temp,0,inr) call mybarrier() call writeit0(foz,temp,0,inr) call mybarrier() end if if(nmhd.eq.n) then call writeit0(pm,temp,1,inr) call mybarrier() call writeit0(bx,temp,1,inr) call mybarrier() call writeit0(by,temp,1,inr) call mybarrier() call writeit0(bz,temp,1,inr) call mybarrier() call writeit0(fbx,temp,1,inr) call mybarrier() call writeit0(fby,temp,1,inr) call mybarrier() call writeit0(fbz,temp,1,inr) call mybarrier() c mod-restart call writeit0(bx1,temp,1,inr) call mybarrier() call writeit0(by1,temp,1,inr) call mybarrier() call writeit0(bz1,temp,1,inr) call mybarrier() call writeit0(bxe,temp,1,inr) call mybarrier() call writeit0(bye,temp,1,inr) call mybarrier() call writeit0(bze,temp,1,inr) call mybarrier() else call writeit0(pm,temp,0,inr) call mybarrier() call writeit0(bx,temp,0,inr) call mybarrier() call writeit0(by,temp,0,inr) call mybarrier() call writeit0(bz,temp,0,inr) call mybarrier() call writeit0(fbx,temp,0,inr) call mybarrier() call writeit0(fby,temp,0,inr) call mybarrier() call writeit0(fbz,temp,0,inr) call mybarrier() c mod-restart call writeit0(bx1,temp,0,inr) call mybarrier() call writeit0(by1,temp,0,inr) call mybarrier() call writeit0(bz1,temp,0,inr) call mybarrier() call writeit0(bxe,temp,0,inr) call mybarrier() call writeit0(bye,temp,0,inr) call mybarrier() call writeit0(bze,temp,0,inr) call mybarrier() end if if (nms.eq.n) then call writeit0(qv,temp,1,inr) call mybarrier() call writeit0(qc,temp,1,inr) call mybarrier() call writeit0(qr,temp,1,inr) call mybarrier() call writeit0(fqv,temp,1,inr) call mybarrier() call writeit0(fqc,temp,1,inr) call mybarrier() call writeit0(fqr,temp,1,inr) call mybarrier() else call writeit0(qv,temp,0,inr) call mybarrier() call writeit0(qc,temp,0,inr) call mybarrier() call writeit0(qr,temp,0,inr) call mybarrier() call writeit0(fqv,temp,0,inr) call mybarrier() call writeit0(fqc,temp,0,inr) call mybarrier() call writeit0(fqr,temp,0,inr) call mybarrier() end if if (nicp.eq.n) then call writeit0(qia,temp,1,inr) call mybarrier() call writeit0(qib,temp,1,inr) call mybarrier() call writeit0(fqia,temp,1,inr) call mybarrier() call writeit0(fqib,temp,1,inr) call mybarrier() else call writeit0(qia,temp,0,inr) call mybarrier() call writeit0(qib,temp,0,inr) call mybarrier() call writeit0(fqia,temp,0,inr) call mybarrier() call writeit0(fqib,temp,0,inr) call mybarrier() end if if (nkv.eq.n) then call writeit0(tke,temp,1,inr) call mybarrier() else call writeit0(tke,temp,0,inr) call mybarrier() end if if (nke.eq.n) then call writeit0(ftke,temp,1,inr) call mybarrier() else call writeit0(ftke,temp,0,inr) call mybarrier() end if do jfil=1,nspc call writeit0( chm(1-ih,1-ih,1,jfil),temp,ichm,inr) call mybarrier() enddo do jfil=1,nspc call writeit0(fchm(1-ih,1-ih,1,jfil),temp,ichm,inr) call mybarrier() enddo if (ihis.eq.1) write(14) hise,hischm return end c mod-restart subroutine iowritek(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() call writeitk(ox,ifullarr) call mybarrier() call writeitk(oy,ifullarr) call mybarrier() call writeitk(oz,ifullarr) call mybarrier() c mod-restart call writeitk(ox2,ifullarr) call mybarrier() call writeitk(oy2,ifullarr) call mybarrier() call writeitk(oz2,ifullarr) call mybarrier() call writeitk(th,ifullarr) call mybarrier() call writeitk(p,ifullarr) call mybarrier() call writeitk(fx,ifullarr) call mybarrier() call writeitk(fy,ifullarr) call mybarrier() call writeitk(fz,ifullarr) call mybarrier() call writeitk(ft,ifullarr) call mybarrier() if (nts.eq.n) then call writeitk(fox,1) call mybarrier() call writeitk(foy,1) call mybarrier() call writeitk(foz,1) call mybarrier() else call writeitk(fox,0) call mybarrier() call writeitk(foy,0) call mybarrier() call writeitk(foz,0) call mybarrier() end if if (nmhd.eq.n) then call writeitk(pm,1) call mybarrier() call writeitk(bx,1) call mybarrier() call writeitk(by,1) call mybarrier() call writeitk(bz,1) call mybarrier() call writeitk(fbx,1) call mybarrier() call writeitk(fby,1) call mybarrier() call writeitk(fbz,1) call mybarrier() c mod-restart call writeitk(bx1,1) call mybarrier() call writeitk(by1,1) call mybarrier() call writeitk(bz1,1) call mybarrier() call writeitk(bxe,1) call mybarrier() call writeitk(bye,1) call mybarrier() call writeitk(bze,1) call mybarrier() else call writeitk(pm,0) call mybarrier() call writeitk(bx,0) call mybarrier() call writeitk(by,0) call mybarrier() call writeitk(bz,0) call mybarrier() call writeitk(fbx,0) call mybarrier() call writeitk(fby,0) call mybarrier() call writeitk(fbz,0) call mybarrier() c mod-restart call writeitk(bx1,0) call mybarrier() call writeitk(by1,0) call mybarrier() call writeitk(bz1,0) call mybarrier() call writeitk(bxe,0) call mybarrier() call writeitk(bye,0) call mybarrier() call writeitk(bze,0) call mybarrier() end if if (nms.eq.n) then call writeitk(qv,1) call mybarrier() call writeitk(qc,1) call mybarrier() call writeitk(qr,1) call mybarrier() call writeitk(fqv,1) call mybarrier() call writeitk(fqc,1) call mybarrier() call writeitk(fqr,1) call mybarrier() else call writeitk(qv,0) call mybarrier() call writeitk(qc,0) call mybarrier() call writeitk(qr,0) call mybarrier() call writeitk(fqv,0) call mybarrier() call writeitk(fqc,0) call mybarrier() call writeitk(fqr,0) call mybarrier() end if if (nicp.eq.n) then call writeitk(qia,1) call mybarrier() call writeitk(qib,1) call mybarrier() call writeitk(fqia,1) call mybarrier() call writeitk(fqib,1) call mybarrier() else call writeitk(qia,0) call mybarrier() call writeitk(qib,0) call mybarrier() call writeitk(fqia,0) call mybarrier() call writeitk(fqib,0) call mybarrier() end if if (nkv.eq.n) then call writeitk(tke,1) call mybarrier() else call writeitk(tke,0) call mybarrier() end if if (nke.eq.n) then call writeitk(ftke,1) call mybarrier() else call writeitk(ftke,0) call mybarrier() end if do jfil=1,nspc call writeitk( chm(1-ih,1-ih,1,jfil),ichm) call mybarrier() enddo do jfil=1,nspc call writeitk(fchm(1-ih,1-ih,1,jfil),ichm) call mybarrier() enddo return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IORFLAG == 0) /* PE0 read serial array and reditribute it between other PEs */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0(datarr,temp,ifullarr,icomm,inr) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) call readit0tape(temp,fval,ifullarr,inr,n,m) if (icomm.eq.1) then if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data from big array to local array ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=temp(i,j,k) end do end do end do #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, sending them their data ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp do i=1,np tmparray(i,j,k) = . temp(((npos1-1)*np + i), ((mpos1-1)*mp + j), k) end do end do end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_put32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_put64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_put(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc end do #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccccccccccccccc c read full array from tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 - degenerate array; read one value tempval=fval #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccc c send data from pe 0 to other processors ccccccccccccccccccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) call shmem_barrier_all() ! tempval is available in common block #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccc c end of read one value ccccccccccccccccccccccccccccc end if !ifullarr end if !icomm = 1 return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IORFLAG == 0 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IOWFLAG == 0) /* PE0 collect data to one big array + write it to the tape */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0(datarr,temp,ifullarr,inr) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif !mod check common/blocktemp/tmparray(np,mp,l),tempval dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data to big array ccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np temp(i,j,k)=datarr(i,j,k) end do end do end do #if (PARALLEL > 0) /* get data from other processors */ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp do i=1,np temp(((npos1-1)*np + i), ((mpos1-1)*mp + j), k)= . tmparray(i,j,k) end do end do end do end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors done cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif /* (PARALLEL > 0) */ else !ifullarr = 0 c fval=1.0 ! degenerate array; fval=tempval ! write out one value from PE = 0 end if if(inr.ge.0) + call writeit0tape(temp,fval,ifullarr,inr,n,m) return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine bridge_send(dataarr_eu, ind, iblock, rqst) c c this subroutine should be able to send all data into processor 0 of MPI_COMM_WORLD c include 'param.nml' include 'msg.inc' #if (PARALLEL>0) #include "msg.lnk" #include "msg.lnp" #endif integer iproc, lengi, ind integer, dimension(0:nprocx_frn-1)::rqst real temp dimension dataarr_eu( 1-ih:np+ih,1-ih:mp+ih,l) integer :: iblock !common/blocktemp/temparray(l,mp,np) real, dimension(l,mp,np) :: temparray c transfer data to a regular array, EULAG does it all the time !print *, 'EULAG - peer_frn', mype, peer_frn do iproc=0, nprocx_frn - 1 nmlp = np*mp*(xind_rng(iproc,2) - xind_rng(iproc, 1) + 1) !count for mpi_send if(iblock >=3) then call MPI_WAIT(rqst(iproc),status,ierr) print*, 'EULAG: NON_BLOCKING', mype, iblock, + status(MPI_SOURCE),status(MPI_TAG),status(MPI_ERROR) endif do k=xind_rng(iproc,1), xind_rng(iproc, 2) do j=1, mp do i=1, np temparray(k,j,i) = dataarr_eu(i,j,k) enddo enddo enddo ! print *,'EULAG - rank, peer, tag, leng', ! . mype,peer_frn+iproc, mype, nmlp if(iblock>=2) then call MPI_ISend(temparray(xind_rng(iproc,1): + xind_rng(iproc,2),:,:), + nmlp,DC_TYPE,peer_frn+iproc,mype,MPI_COMM_WORLD, + rqst(iproc),ierr) ! print*, 'EULAG: NON_BLOCKING', mype, rqst(iproc), iblock else call MPI_Send(temparray(xind_rng(iproc,1): + xind_rng(iproc,2),:,:), + nmlp,DC_TYPE,peer_frn+iproc,mype,MPI_COMM_WORLD,ierr) endif enddo if(ind.eq.1) . write(30+mype) temparray if(ind.eq.2) . write(40+mype) temparray if(ind.eq.3) . write(50+mype) temparray ! print *,'EULAG Finished send' call mybarrier() end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine bridge_velo_send(u,v,w) ! Just this 3 for now c c This subroutine will send the field/other variables to Pencil c include 'param.nml' include 'msg.inc' #if (PARALLEL>0) #include "msg.lnk" #endif dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l) integer,save::iblock=0 integer,save,dimension(0:nprocx_frn_max-1,3)::rqst double precision :: time0,time1, time2 c Need to be send in the sme order as the receiver if (mype.eq.0.and.iblock.eq.0) time0 = MPI_WTIME() if (mype.eq.0) time1 = MPI_WTIME() call bridge_send(w,3,iblock,rqst(:nprocx_frn-1,3)) call bridge_send(v,2,iblock,rqst(:nprocx_frn-1,2)) call bridge_send(u,1,iblock,rqst(:nprocx_frn-1,1)) if (mype.eq.0) then time2 = MPI_WTIME() print*,'EULAG walltime[min]tot', . iblock, (time2-time0)/60. endif iblock = iblock+1 print *, 'EULAG MIN MAX W', mype,minval(w(1:np,1:mp,:)), . maxval(w(1:np,1:mp,:)) print *, 'EULAG MIN MAX V', mype,minval(v(1:np,1:mp,:)), . maxval(v(1:np,1:mp,:)) print *, 'EULAG MIN MAX U', mype,minval(u(1:np,1:mp,:)), . maxval(u(1:np,1:mp,:)) print*, 'EULAG: successful', mype ! call MPI_BARRIER(MPI_COMM_WORLD, ierr) ! call MPI_FINALIZE(ierr) ! stop return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IOWFLAG == 0 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IORFLAG == 1) /* Read arrays written sequentially, distribute them to PEs */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0(datarr,temp,ifullarr,icomm,inr) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval nmlp=np*mp*l #endif if (ifullarr.eq.1) then do iproc=0,(nprcxa*nprcya - 1) call readit0tape(temp,fval,ifullarr,inr,npa,mpa) if (icomm.eq.1) then #if (PARALLEL == 0) npos1 = mod((iproc+nprcxa), nprcxa) + 1 mpos1 = iproc/nprcxa + 1 do k=1,l do j=1,mpa do i=1,npa datarr(((npos1-1)*npa+i),((mpos1-1)*mpa+j),k)=temp(i,j,k) end do end do end do #else if (iproc.eq.0) then do k=1,l do j=1,mpa do i=1,npa datarr(i,j,k)=temp(i,j,k) end do end do end do else cccccccccccccccccccccccccccccccccccccccccccccc c send small arrays for other processors cccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np tmparray(i,j,k) = temp(i,j,k) end do end do end do #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_put32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_put64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_put(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccc c send small arrays for other processors cccccccccccccccccccccccccccccccccccccccccccccc end if ! iproc #endif /* (PARALLEL > 0) */ end if ! icomm end do ! iproc else !ifullarr = 0 ! degenerate array; read one value call readit0tape(temp,fval,ifullarr,inr,np,mp) if (icomm.eq.1) then tempval=fval #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccc c send data from pe 0 to other processors ccccccccccccccccccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) call shmem_barrier_all() ! tempval is available in common block #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccc c end of read one value ccccccccccccccccccccccccccccc end if !icomm = 1 end if !ifullarr return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IORFLAG == 1 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IOWFLAG == 1) /* Collect arrays from PEs, write them sequentially to tape */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0(datarr,temp,ifullarr,inr) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) if (ifullarr.eq.1) then do k=1,l do j=1,mp do i=1,np temp(i,j,k)=datarr(i,j,k) end do end do end do call writeit0tape(temp,fval,ifullarr,inr,np,mp) #if (PARALLEL > 0) /* get data from other processors */ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and write it to tape cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif do k=1,l do j=1,mp do i=1,np temp(i,j,k)= tmparray(i,j,k) end do end do end do call writeit0tape(temp,fval,ifullarr,inr,np,mp) end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors done cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif /* (PARALLEL > 0) */ else !ifullarr = 0 c fval=1.0 ! degenerate array; fval=tempval ! write out one value from PE = 0 call writeit0tape(temp,fval,ifullarr,inr,np,mp) end if return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IOWFLAG == 1 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readitk(datarr,ifullarr,icomm) c c This subroutine collect data from PE0 on other PEs c include 'param.nml' include 'msg.inc' dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval if (icomm.eq.1) then if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccc c receive array from pe 0 ccccccccccccccccccccccccccccccc nmlp=np*mp*l #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #else call pvmfrecv(0, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readitk' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, 0, 98, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccc c transfer received array to local array cccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=tmparray(i,j,k) end do end do end do cccccccccccccccccccccccccccccccccccccc c end of receive array from pe 0 cccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 ccccccccccccccccccccccccccccccc c receive value from pe 0 ccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tempval,tempval,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(tempval,tempval,1,0) #endif #if (SGI_O2K == 0) call shmem_get(tempval,tempval,1,0) #endif call shmem_barrier_all() #else call pvmfrecv(0, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readitk' stop end if call pvmfunpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif cccccccccccccccccccccccccccccc c end of receive one value cccccccccccccccccccccccccccccc endif !ifullarr endif !icomm = 1 #endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeitk(datarr,ifullarr) c c This subroutine send data to PE0 to write them to the history file c include 'param.nml' include 'msg.inc' dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval nmlp=np*mp*l if (ifullarr.eq.1) then cccccccccccccccccccccccccccccccccccc c transfer data to regular array cccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np tmparray(i,j,k)=datarr(i,j,k) end do end do end do ccccccccccccccccccccccccccccccc c send data to processor 0 ccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif end if #endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0tape(temp,fval,ifullarr,inr,n1,m1) c c This subroutine reads the data from the history file by PE0 c include 'param.nml' include 'msg.inc' #if (HP > 0 || SGI_O2K > 1) integer CRAYREAD #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (IORTAPE == 3) real*8 temp(n1,m1,l) real*8 fval #endif #if (IORTAPE == 2) real*4 temp(n1,m1,l) real*4 fval #endif #if (IORTAPE == 1) dimension temp(n1,m1,l) real fval #endif if (ifullarr.eq.1) then cccccccccccccccccccccccccccccccccccccc c read full array from tape file cccccccccccccccccccccccccccccccccccccc nml=n1*m1*l #if (HP > 0 ) c read data on HP/Convex machine c ifcr =/= 0 file opened by CRAYOPEN if(ioptr.eq.0) then c read data from HP/Convex or IBM machines read(inr)temp endif if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, temp, nml, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, temp, nml, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) c read data on SGI Origin 2000 machine c NCARU liblaries not available; read data from SGI Origin 2000 machine read(inr)temp #endif #if(SGI_O2K == 2) c read data on SGI Origin 2000 machine c ifcr =/= 0 file opened by CRAYOPEN if(ioptr.eq.0) then c read data from SGI read(inr)temp endif if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, temp, nml, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, temp, nml, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif c read data on Cray machines or on workstation #if (CRAYPVP == 1) read(inr)temp c IOPTR=0 read data from HP/Convex machines : assign -F f77 N ieee_64 u:9 c IOPTR=2 read data from CRAY PVP machines : dont convert datas if (ioptr.eq.1) then c read data from CRAY MPP machines Converts IEEE/Generic 32-bit (on a generic 32-bit platform) data to Cray Research 64-bit data ierr=IEG2CRAY(8,nml,temp,0,temp,1) if(ierr.lt.0) . print *,'IEG2CRAY error:',ierr,' no translation performed' endif #endif #if (CRAYT3D == 1 || CRAYT3E == 1) read(inr)temp c IOPTR=0 read data from HP/Convex machines : assign -F f77 u:9 c IOPTR=1 read data from CRAY MPP machines : dont convert datas if(ioptr.eq.2) then Converts Cray Research PVP 64-bit data to IEEE/MPP 64-bit data print *,'array size is nml=',nml print *,'CRAY2CRI( 2, nml, temp, 0 , temp, 1 )' ierr=CRAY2CRI( 2, nml, temp, 0 , temp, 1 ) if(ierr.lt.0) . print *,'CRAY2CRI error:',ierr,' no translation performed' endif #endif #if (WORKS > 0 || IBM > 0 || PLE > 0 || LNX >0) c read data on "FUJI VPP 700" "IBM" or "Workstation" read(inr)temp #endif ccccccccccccccccccccccccccccccccccccccccc c read full array from tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 cccccccccccccccccccccccccccccccccccccccc c read one value from tape file cccccccccccccccccccccccccccccccccccccccc nml=1 #if (HP > 0 ) if(ioptr.eq.0) then c read data from HP/Convex or IBM machines read(inr)fval else if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, fval, 1, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' else if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, fval, 1, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if (SGI_O2K == 1) if(ioptr.eq.0) then c read data from HP/Convex/SGI Origin machines read(inr)fval endif #endif #if (SGI_O2K == 2) if(ioptr.eq.0) then c read data from HP/Convex/SGI Origin machines read(inr)fval else if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, fval, 1, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' else if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, fval, 1, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) read(inr)fval c IOPTR=0 read data from HP/Convex machines : assign -F f77 N ieee_64 u:9 c IOPTR=2 read data from CRAY PVP machines : dont convert datas if (ioptr.eq.1) then c read data from CRAY MPP machines Converts IEEE/Generic 32-bit (on a generic 32-bit platform) data to Cray Research 64-bit data ierr=IEG2CRAY(8,1,fval,0,fval,1) if(ierr.lt.0) . print *,'IEG2CRAY error:',ierr,' no translation performed' endif #endif #if (CRAYT3D == 1 || CRAYT3E == 1) read(inr)fval c IOPTR=0 read data from HP/Convex machines : assign -F f77 u:9 c IOPTR=1 read data from CRAY MPP machines : dont convert datas if(ioptr.eq.2) then Converts Cray Research PVP 64-bit data to IEEE/MPP 64-bit data print *,'array size is =',1 print *,'CRAY2CRI( 2, 1, fval, 0 , fval, 1 )' ierr=CRAY2CRI( 2, 1, fval, 0 , fval, 1 ) if(ierr.lt.0) . print *,'CRAY2CRI error:',ierr,' no translation performed' endif #endif #if (WORKS > 0 || IBM > 0 || PLE > 0 || LNX >0) read(inr)fval #endif cccccccccccccccccccccccccccccccccccccccc c read one value from tape file done cccccccccccccccccccccccccccccccccccccccc endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0tape(temp,fval,ifullarr,inr,n1,m1) c c This subroutine writes the data to the history file by PE0 c include 'param.nml' include 'msg.inc' #if (HP > 0 || SGI_O2K > 1 || IBM > 0|| LNX >0 || PLE > 0) integer CRAYWRITE #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (IOWTAPE == 3) real*8 temp(n1,m1,l) real*8 fval #endif #if (IOWTAPE == 2) real*4 temp(n1,m1,l) real*4 fval #endif #if (IOWTAPE == 1) dimension temp(n1,m1,l) real fval #endif if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccc c write data to the tape file ccccccccccccccccccccccccccccccccc nml=n1*m1*l #if (HP > 0) if(ioptw.eq.0) then write(inr)temp endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) C NCARU libraries not available for WORD = 4 write(inr)temp #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(inr)temp endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 -N ieee_64 u:9 c IOPTW=2 write data to CRAY PVP machines : dont convert datas if(ioptw.eq.1) then Converts Cray Research 64-bit data to IEEE/Generic 32-bit data ierr=CRAY2IEG( 8, nml, temp, 0, temp, 1) if(ierr.lt.0) . print *,'CRAY2IEG error:',ierr,' no translation performed' endif write(inr)temp #endif #if (CRAYT3D == 1 || CRAYT3E == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 u:9 c IOPTW=1 write data to CRAY MPP machines : dont convert datas if(ioptw.eq.2) then Converts IEEE/MPP 64-bit data to Cray Research PVP 64-bit data print *,'size array is nml=',nml print *,'CRI2CRAY( 2, nml, temp, 0 , temp, 1 )' ierr=CRI2CRAY( 2, nml, temp, 0 , temp, 1 ) if(ierr.lt.0) . print *,'CRI2CRAY error:',ierr,' no translation performed' endif write(inr)temp #endif #if (WORKS > 0 || FUJI_VPP > 0 || IBM > 0 || LNX >0 || PLE > 0) write(inr)temp #endif ccccccccccccccccccccccccccccccccccccccccc c write full array to tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 ccccccccccccccccccccccccccccccccccccccccc c write out one value ccccccccccccccccccccccccccccccccccccccccc nml=1 #if (HP > 0) if(ioptw.eq.0) then write(inr)fval endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) C NCARU libraries not available for WORD = 4 write(inr)fval #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(inr)fval endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 -N ieee_64 u:9 c IOPTW=2 write data to CRAY PVP machines : dont convert datas if(ioptw.eq.1) then Converts Cray Research 64-bit data to IEEE/Generic 32-bit data ierr=CRAY2IEG( 8, 1, fval, 0, fval, 1) if(ierr.lt.0) . print *,'CRAY2IEG error:',ierr,' no translation performed' endif write(inr)fval #endif #if (CRAYT3D == 1 || CRAYT3E == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 u:9 c IOPTW=1 write data to CRAY MPP machines : dont convert datas if(ioptw.eq.2) then Converts IEEE/MPP 64-bit data to Cray Research PVP 64-bit data print *,'size array is nml=',nml print *,'CRI2CRAY( 2, 1, fval, 0 , fval, 1 )' ierr=CRI2CRAY( 2, 1, fval, 0 , fval, 1 ) if(ierr.lt.0) . print *,'CRI2CRAY error:',ierr,' no translation performed' endif write(inr)fval #endif #if (IBM > 0 || WORKS > 0 || FUJI_VPP > 0 || LNX >0 || PLE > 0) write(inr)fval #endif cccccccccccccccccccccccccccccc c write out one value done cccccccccccccccccccccccccccccc end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C S T O P - U N T I L A L L P R O C E S S O R S A R E R E A D Y C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine mybarrier() c c my barrier (machine specific) c #include "msg.lnk" #if (PARALLEL == 2) CMPITEST print *,'Barier',rank #if (CRAYPVP == 1) CPVP Barier Dont Work #else CO2K Barier Dont Scale Above 32 PE, but we need it for I/O operations C call MPI_Barrier(MPI_COMM_EULAG, ierr) #endif CMPITEST print *,'After Barier',rank #endif #if (PARALLEL == 1) integer psync(SHMEM_REDUCE_SYNC_SIZE) data psync/SHMEM_REDUCE_SYNC_SIZE*SHMEM_SYNC_VALUE/ #if (SGI_O2K > 0) call shmem_barrier_all() #else call barrier() #endif c call shmem_barrier(0,0,n$pes,psync) #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C G L O B A L S U M S , M A X I M A S , M I N I M A S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #define DIAGPLT 0 /* 1=prints for dignose */ #if (PARALLEL > 0) c --------------------------------------- c calculate sums on the MPP computers c --------------------------------------- function globsum(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) include 'param.nml' include 'msg.inc' #include "msg.lnk" common /csum/psum,tsum,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif integer DC_TSUM real globsum #if (SUMR16 == 1) real*16 psum0,pa,psum,tsum,work DC_TSUM = MPI_DOUBLE_PRECISION ict=2 #else real psum0,pa,psum,tsum,work c real*8 psum0,pa,psum,tsum,work DC_TSUM = DC_TYPE ict=1 #endif #if (DIAGPLT == 1) print *,'Insite Globsum',mype #endif #if (TIMEPLT == 1) call ttbeg(78) #endif psum0=0. do k=k1,k2 do j=j1,j2 do i=i1,i2 psum0=psum0+array(i,j,k) end do end do end do psum=psum0 #if (PARALLEL == 2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c routine MPI_ALLReduce is standart but work slowly (4.3 / 3.5) c CALL MPI_ALLReduce(psum,pa,ict,DC_TSUM,MPI_SUM,MPI_COMM_EULAG,ir) c globsum=pa c return cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif nodes = mysize tsum=psum c compute global sum if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(tsum,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG,status, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,tsum,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,tsum,1,neighbor) #endif #else call shmem_put(work,tsum,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif CCCCCCCCCCCCCCCCCCC tsum = tsum + work bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor.lt.nodes .and. and(mype,prevbits) .eq. 0) then if(and(bit,mype).eq.bit) then CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 2) call MPI_Send(tsum,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,tsum,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,tsum,1,neighbor) #endif #else call shmem_put(work,tsum,1,neighbor) #endif #endif CCCCCCCCCCCCCCCCCCC end if end if #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor.lt.nodes .and. and(mype,prevbits) .eq. 0) then if(and(bit,mype).eq.0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, status,ierr) #endif tsum=tsum+work end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) end do CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 2) call MPI_Bcast(tsum,ict,DC_TSUM,0,MPI_COMM_EULAG, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tsum,tsum,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(tsum,tsum,1,0) #endif #else call shmem_get(tsum,tsum,1,0) #endif endif call shmem_barrier_all() #endif CCCCCCCCCCCCCCCCCCC end if 99 continue globsum=tsum #if (TIMEPLT == 1) call ttend(78) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' globsum =',globsum c stop 'globsum' #endif return end #else c --------------------------------------- c calculate sums on nonparallel computers c --------------------------------------- function globsum(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif #if (SUMR16 == 1) real*16 psum0,psum #else c real*16 psum0 c real psum real*8 psum0,psum #endif real globsum #if (TIMEPLT == 1) call ttbeg(78) #endif psum0=0. do k=k1,k2 do j=j1,j2 do i=i1,i2 psum0=psum0+array(i,j,k) end do end do end do psum=psum0 globsum=psum #if (TIMEPLT == 1) call ttend(78) #endif return end #endif function globmax(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) c ------------------------------ c calculate max on MPP computers c ------------------------------ include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" common /cmax/flocmax,fglobmax,pwrk,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #endif #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif real globmax #if (DIAGPLT == 1) print *,'Insite Globmax',mype #endif #if (TIMEPLT == 1) call ttbeg(79) #endif c compute local max first c flocmax=array(1,1,1) flocmax=-1.e30 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmax=amax1(flocmax,array(i,j,k)) end do end do end do fglobmax=flocmax #if (PARALLEL > 0) nodes = mysize #if (PARALLEL == 2) ict=1 #endif c compute global max if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmax,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG,status, ierr) #endif #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmax,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmax,1,neighbor) #endif #else call shmem_put(work,fglobmax,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif fglobmax = amax1(fglobmax,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. bit) then #if (PARALLEL == 2) call MPI_Send(fglobmax,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmax,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmax,1,neighbor) #endif #else call shmem_put(work,fglobmax,1,neighbor) #endif #endif endif endif #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. 0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG,status, ierr) #endif fglobmax=amax1(fglobmax,work) end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) enddo #if (PARALLEL == 2) call MPI_Bcast(fglobmax,ict,DC_TYPE,0,MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(fglobmax,fglobmax,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(fglobmax,fglobmax,1,0) #endif #else call shmem_get(fglobmax,fglobmax,1,0) #endif endif call shmem_barrier_all() #endif end if 99 continue #endif globmax=fglobmax #if (TIMEPLT == 1) call ttend(79) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' globmax =',globmax #endif return end function globmin(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) c c calculate min on MPP computers c include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" common /cmin/flocmin,fglobmin,pwrk,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #endif #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif real globmin #if (DIAGPLT == 1) print *,'Insite Globmin',mype #endif #if (TIMEPLT == 1) call ttbeg(80) #endif c compute local min first c flocmin=array(1,1,1) flocmin=1.e30 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmin=amin1(flocmin,array(i,j,k)) end do end do end do fglobmin=flocmin #if (PARALLEL > 0) nodes = mysize #if (PARALLEL == 2) ict=1 #endif c compute global min if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmin,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG,status, ierr) #endif #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmin,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmin,1,neighbor) #endif #else call shmem_put(work,fglobmin,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif fglobmin = amin1(fglobmin,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. bit) then #if (PARALLEL == 2) call MPI_Send(fglobmin,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmin,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmin,1,neighbor) #endif #else call shmem_put(work,fglobmin,1,neighbor) #endif #endif endif endif #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. 0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG,status, ierr) #endif fglobmin=amin1(fglobmin,work) end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) enddo #if (PARALLEL == 2) call MPI_Bcast(fglobmin,ict,DC_TYPE,0,MPI_COMM_EULAG,ierr) #endif #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(fglobmin,fglobmin,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(fglobmin,fglobmin,1,0) #endif #else call shmem_get(fglobmin,fglobmin,1,0) #endif endif call shmem_barrier_all() #endif end if 99 continue #endif globmin=fglobmin #if (TIMEPLT == 1) call ttend(80) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' fglobmin =',fglobmin #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C U P D A T E S H A L L O B E T W E E N P R O C E S S O R S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (POLES == 0) subroutine updatew(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(75) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=(n2-n1+1)*ihr*l1 mhl=ihr*(m2-m1+1)*l1 ihl=ihr*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 #if (PARALLEL == 0) c tmpxrcv1=a(i,j,k) c tmpxrcv2=a(i,m2-ihr+j,k) c a(i,m2+j ,k)=tmpxrcv1 c a(i,m1-1-ihr+j,k)=tmpxrcv2 a(i,m2+j ,k)=a(i, j,k) a(i,m1-1-ihr+j,k)=a(i,m2-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a(i,j,k) c tmpyrcv2=a(n2-ihr+i,j,k) c a(n1+i ,j,k)=tmpyrcv1 c a(n1-1-ihr+i,j,k)=tmpyrcv2 a(n2+i ,j,k)=a( i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do c print *,'PARALLEL',mype #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 a(i,m2+j,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 a(n2+i,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n2-ihr+i,m2-ihr+j,k) tmpcorrcv2=a(n2-ihr+i, j,k) tmpcorrcv3=a(i , j,k) tmpcorrcv4=a(i ,m2-ihr+j,k) a(n1-1+i-ihr,m1-1+j-ihr,k)=tmpcorrcv1 a(n1-1+i-ihr,m2+j ,k)=tmpcorrcv2 a(n2+i ,m2+j ,k)=tmpcorrcv3 a(n2+i ,m1-1+j-ihr,k)=tmpcorrcv4 c a(n1-1+i-ihr,m1-1+j-ihr,k)=a(n2-ihr+i,m2-ihr+j,k) c a(n1-1+i-ihr,m2+j ,k)=a(n2-ihr+i,j ,k) c a(n2+i ,m2+j ,k)=a(i ,j ,k) c a(n2+i ,m1-1+j-ihr,k)=a(i ,m2-ihr+j,k) #else tmpcorsnd1(icnt)=a(n2-ihr+i,m2-ihr+j,k) tmpcorsnd2(icnt)=a(n2-ihr+i, j,k) tmpcorsnd3(icnt)=a(i , j,k) tmpcorsnd4(icnt)=a(i ,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 a(n1-1+i-ihr,m1-1+j-ihr,k)=tmpcorrcv1(icnt) a(n1-1+i-ihr,m2+j ,k)=tmpcorrcv2(icnt) a(n2+i ,m2+j ,k)=tmpcorrcv3(icnt) a(n2+i ,m1-1+j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(75) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATEW',mype #endif return end subroutine updatebtw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPD_BTW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(76) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=(n2-n1+1)*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m2-ihr+j,k) c a(i,m2+j ,k)=tmpxrcv1 c a(i,m1-1-ihr+j,k)=tmpxrcv2 a(i,m2+j ,k)=a(i, j,k) a(i,m1-1-ihr+j,k)=a(i,m2-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 a(i,m2+j ,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do #endif #if (TIMEPLT == 1) call ttend(76) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATEBTW',mype #endif return end subroutine updatelrw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPD_LRW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(77) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*(m2-m1+1)*l1 c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a(i ,j,k) c tmpyrcv2=a(n2-ihr+i,j,k) c a(n1+i ,j,k)=tmpyrcv1 c a(n1-1-ihr+i,j,k)=tmpyrcv2 a(n2+i ,j,k)=a( i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 a(n2+i ,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif #if (TIMEPLT == 1) call ttend(77) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATELRW',mype #endif return end subroutine update(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATE',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) print *, 'Parallel == 1' call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=ihr*m1*l1 ihl=ihr*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c print *,'PARALLEL done',mype c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ihr+i,m1-ihr+j,k) tmpcorrcv2=a(n1-ihr+i, j,k) tmpcorrcv3=a( i, j,k) tmpcorrcv4=a( i,m1-ihr+j,k) a(i-ihr,j-ihr,k)=tmpcorrcv1 a(i-ihr, m1+j,k)=tmpcorrcv2 a( n1+i, m1+j,k)=tmpcorrcv3 a( n1+i,j-ihr,k)=tmpcorrcv4 c a(i-ihr,j-ihr,k)=a(n1-ihr+i,m1-ihr+j,k) c a(i-ihr, m1+j,k)=a(n1-ihr+i, j,k) c a( n1+i, m1+j,k)=a( i, j,k) c a( n1+i,j-ihr,k)=a( i,m1-ihr+j,k) #else tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i, j,k) tmpcorsnd3(icnt)=a( i, j,k) tmpcorsnd4(icnt)=a( i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif c print *,'PARALLEL 2 done',mype icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr, m1+j,k)=tmpcorrcv2(icnt) a( n1+i, m1+j,k)=tmpcorrcv3(icnt) a( n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATE',mype #endif return end subroutine update2(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATE2',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(71) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=m1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below: tmpxsnd1 c prepare top segments for processor above : tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,13,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,14,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,13, . tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,14, . tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(71) #endif #if (DIAGPLT == 1) print *,'OUT UPDATE2',mype #endif return end #if (SEMILAG == 1) subroutine updatelagr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' parameter (l3=l+2*ior) dimension a(1-ihlag-ior:ndim+ihlag+ior, . 1-ihlag-ior:mdim+ihlag+ior,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updlagr/ tmpxsnd1((np+2*ior)*ihlag*l3), . tmpxsnd2((np+2*ior)*ihlag*l3), . tmpysnd1((mp+2*ior)*ihlag*l3), . tmpysnd2((mp+2*ior)*ihlag*l3), . tmpcorsnd1(ihlag*ihlag*l3), . tmpcorsnd2(ihlag*ihlag*l3), . tmpcorsnd3(ihlag*ihlag*l3), . tmpcorsnd4(ihlag*ihlag*l3), . tmpxrcv1((np+2*ior)*ihlag*l3), . tmpxrcv2((np+2*ior)*ihlag*l3), . tmpyrcv1((mp+2*ior)*ihlag*l3), . tmpyrcv2((mp+2*ior)*ihlag*l3), . tmpcorrcv1(ihlag*ihlag*l3), . tmpcorrcv2(ihlag*ihlag*l3), . tmpcorrcv3(ihlag*ihlag*l3), . tmpcorrcv4(ihlag*ihlag*l3) #endif #if (DIAGPLT == 1) print *,'UPDATELGR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(72) #endif ihr=min(ihlag,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- if (leftedge.eq.1) then illim=1-ior else illim=1 end if if (rightedge.eq.1) then iulim=n1+ior else iulim=n1 end if if (botedge.eq.1) then jllim=1-ior else jllim=1 end if if (topedge.eq.1) then julim=m1+ior else julim=m1 end if nhl=(iulim-illim+1)*ihr*l1 mhl=(julim-jllim+1)*ihr*l1 ihl=(ihr*ihr*l1) c c------------------------------------------------------------------- c prepare bottom segments for processor below c prepare upper data segments for processor above c------------------------------------------------------------------- c icnt=1 do i=illim,iulim do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpxrcv1=a(i, j,k) tmpxrcv2=a(i,m1-ihr+j,k) a(i, m1+ior+j,k)=tmpxrcv1 a(i,-ior-ihr+j,k)=tmpxrcv2 c a(i, m1+ior+j,k)=a(i, j,k) c a(i,-ior-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the left c prepare right data segments for processor to the right c------------------------------------------------------------------- c icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a( i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a( n1+i+ior,j,k)=tmpyrcv1 a(-ior-ihr+i,j,k)=tmpyrcv2 c a( n1+i+ior,j,k)=a( i,j,k) c a(-ior-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,21,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,22,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,23,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,24,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,21,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,22,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,23,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,24,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,21, . tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,22, . tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,23, . tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,24, . tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 if (topedge.eq.0) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+ior+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (botedge.eq.0) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ior-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (rightedge.eq.0) then do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i+ior,j,k)=tmpyrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (leftedge.eq.0) then do i=1,ihr do j=jllim,julim do k=1,l1 a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=jllim,julim do k=1,l1 a(-ior-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do end if #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ihr+i,m1-ihr+j,k) tmpcorrcv2=a(n1-ihr+i, j,k) tmpcorrcv3=a( i, j,k) tmpcorrcv4=a( i,m1-ihr+j,k) a(i-ihr-ior,j-ihr-ior,k)=tmpcorrcv1 a(i-ihr-ior, m1+j+ior,k)=tmpcorrcv2 a( n1+i+ior, m1+j+ior,k)=tmpcorrcv3 a( n1+i+ior,j-ihr-ior,k)=tmpcorrcv4 c a(i-ihr-ior,j-ihr-ior,k)=a(n1-ihr+i,m1-ihr+j,k) c a(i-ihr-ior, m1+j+ior,k)=a(n1-ihr+i, j,k) c a( n1+i+ior, m1+j+ior,k)=a( i, j,k) c a( n1+i+ior,j-ihr-ior,k)=a( i,m1-ihr+j,k) #else tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i, j,k) tmpcorsnd3(icnt)=a( i, j,k) tmpcorsnd4(icnt)=a( i,m1-ihr+j,k) c if (i.eq.ihr .and. j.eq.ihr .and. k.eq.11) c . icntkp=icnt icnt=icnt+1 #endif end do end do end do c if (mype.eq.17) then c write(*,*)'***tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1)=', c . tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1) c end if #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif icnt=1 if (leftedge.eq.0 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) c if (i.eq.ihr .and. j.eq.ihr .and. k.eq.11) c . icntkp=icnt icnt=icnt+1 end do end do end do c if (mype.eq.26) then c write(*,*)'***tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1)=', c . tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1) c end if else if (leftedge.eq.1 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,j-ihr,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.0 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr-ior,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,j-ihr-ior,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (leftedge.eq.0 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,m1+j,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.0 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j+ior,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,m1+j+ior,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do end if c icnt=1 if (rightedge.eq.0 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.0 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,m1+j+ior,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,m1+j+ior,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (rightedge.eq.0 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.0 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,j-ihr-ior,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,j-ihr-ior,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do end if #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(72) #endif #if (DIAGPLT == 1) print *,'OUT UPDATELAGR',mype #endif return end #endif subroutine updatebt(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATEBT',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(73) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below :tmpxsnd1 c prepare upper data segments for processor above:tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,31,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,32,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,31,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,32,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,31, . tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,32, . tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(73) #endif #if (DIAGPLT == 1) print *,'OUT UPDATEBT',mype #endif return end subroutine updatelr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATELR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(74) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*m1*l1 c c------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,33,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,34,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,33,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,34,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,33, . tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,34, . tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(74) #endif #if (DIAGPLT == 1) print *,'OUT UPDATELR',mype #endif return end #else /* POLES */ #if (SEMILAG == 1) subroutine updatelagr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' parameter (l3=l+2*ior) dimension a(1-ihlag-ior:ndim+ihlag+ior, . 1-ihlag-ior:mdim+ihlag+ior,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updlagr/ tmpxsnd1((np+2*ior)*ihlag*l3), . tmpxsnd2((np+2*ior)*ihlag*l3), . tmpysnd1((mp+2*ior)*ihlag*l3), . tmpysnd2((mp+2*ior)*ihlag*l3), . tmpcorsnd1(ihlag*ihlag*l3), . tmpcorsnd2(ihlag*ihlag*l3), . tmpcorsnd3(ihlag*ihlag*l3), . tmpcorsnd4(ihlag*ihlag*l3), . tmpxrcv1((np+2*ior)*ihlag*l3), . tmpxrcv2((np+2*ior)*ihlag*l3), . tmpyrcv1((mp+2*ior)*ihlag*l3), . tmpyrcv2((mp+2*ior)*ihlag*l3), . tmpcorrcv1(ihlag*ihlag*l3), . tmpcorrcv2(ihlag*ihlag*l3), . tmpcorrcv3(ihlag*ihlag*l3), . tmpcorrcv4(ihlag*ihlag*l3) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(72) #endif ihr=min(ihlag,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- if (leftedge.eq.1) then illim=1-ior else illim=1 end if if (rightedge.eq.1) then iulim=n1+ior else iulim=n1 end if if (botedge.eq.1) then jllim=1-ior else jllim=1 end if if (topedge.eq.1) then julim=m1+ior else julim=m1 end if nhl=(iulim-illim+1)*ihr*l1 mhl=(julim-jllim+1)*ihr*l1 ihl=(ihr*ihr*l1) #if (PARALLEL == 0) do i=illim,iulim do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=jllim,julim do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 end do end do end do do i=1,ihr do j=1,ihr do k=1,l1 tmpcorrcv1=a(ip(n1-ihr+i), j,k) tmpcorrcv2=a(ip(n1-ihr+i),m1+1-j,k) tmpcorrcv3=a(ip(i) ,m1+1-j,k) tmpcorrcv4=a(ip(i) , j,k) a(i-ihr, 1-j,k)=tmpcorrcv1 a(i-ihr,m1+j,k)=tmpcorrcv2 a( n1+i,m1+j,k)=tmpcorrcv3 a( n1+i, 1-j,k)=tmpcorrcv4 end do end do end do #else c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=illim,iulim do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 a( n1+i, j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif c--------------------------------------- c now send and receive corner pieces c--------------------------------------- if (nprocx.eq.1) then if (topedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) a(i-ihr,m1+j,k)=a(ip(n1-ihr+i),m1+1-j,k) a(n1+i, m1+j,k)=a(ip(i) ,m1+1-j,k) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) a(i-ihr, 1-j,k)=a(ip(n1-ihr+i),j,k) a(n1+i, 1-j,k)=a(ip(i) ,j,k) icnt=icnt+1 end do end do end do else icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else !nprocx=1 icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if (nprocx.eq.1) then c updates on poles are just done call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #if (SGI_O2K == 2) if (nprocx.eq.1) then c updates on poles are just done call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #else if (nprocx.eq.1) then c updates on poles are just done call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #endif #if (PARALLEL == 2) call mybarrier() if (nprocx.eq.1) then c updates on poles are just done if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocx>1 if (nprocy.gt.1) then if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocy=1 call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) endif !nprocy endif !nprocx #endif icnt=1 if (nprocx.gt.1) then if (nprocy.gt.1) then if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, -ihr+j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i ,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i , -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i ,m1+j,k)=tmpcorrcv3(icnt) a(n1+i , 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j ,k)=tmpcorrcv2(icnt) a(n1+i ,m1+j ,k)=tmpcorrcv3(icnt) a(n1+i ,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i, m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif !nprocy else !nprocx=1 if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,-ihr+j,k)=tmpcorrcv1(icnt) a(n1+i, -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i, m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr, m1+j,k)=tmpcorrcv2(icnt) a(n1+i, m1+j,k)=tmpcorrcv3(icnt) a(n1+i, j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif endif !nprocx #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(72) #endif #if (DIAGPLT == 1) print *,'UPDATELAG DONE',mype #endif return end #endif subroutine updatebtw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- c nhl=n1*ihr*l1 nhl=(n2-n1+1)*ihr*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=n1,n2 !mod check - modified dim for ip(0) case c do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m2+1-j,k) c tmpxrcv2=a(ip(i),m1+ihr-j,k) a(i, m1-j,k)=tmpxrcv1 c a(i, 1-j,k)=tmpxrcv1 a(i,m2+j,k)=tmpxrcv2 c a(i,m1+j,k)=tmpxrcv2 end do end do end do #else /* (PARALLEL == 0) */ c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=n1,n2 !mod check - modified dim for ip(0) case c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1-j,k)=a(ip(n),j,k) a(i,m1-j,k)=a(ip(i),j,k) c a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m2+j,k)=a(ip(i),m2+1-j,k) c a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else /* SGI_O2K > 0 */ if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif /* SGI_O2K > 0 */ #endif /* PARALLEL == 1 */ #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then ! print *,'MPI_Sendrecv A:',nhl,DC_TYPE,peabove,14,13 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv B:',nhl,DC_TYPE,pebelow,11 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then ! print *,'MPI_Sendrecv C:',nhl,DC_TYPE,pebelow,13,14 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv D:',nhl,DC_TYPE,peabove,12 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif /* PARALLEL == 2 */ c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+j,k)=tmpxrcv1(icnt) c a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+j,k)=tmpxrcv1(icnt) c a(i,m1+j,k)=tmpxrcv1(icnt) a(i, m1-j,k)=tmpxrcv2(icnt) !south pole c a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+1+ihr-j,k)=tmpxrcv1(icnt) !north pole c a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i, m2+j,k)=tmpxrcv1(icnt) c a(i, m1+j,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+1+ihr-j,k)=tmpxrcv1(icnt) !north pole c a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, m1-j,k)=tmpxrcv2(icnt) !south pole c a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif /* (PARALLEL == 0) */ #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 1',mype #endif return end subroutine updatelrw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- c mhl=ihr*m1*l1 mhl=ihr*(m2-m1+1)*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n2-ihr+i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) a(n2+i,j,k)=tmpyrcv1 c a(n1+i,j,k)=tmpyrcv1 a(n1-1-ihr+i,j,k)=tmpyrcv2 c a(-ihr+i,j,k)=tmpyrcv2 end do end do end do #else c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 a(n2+i,j,k)=a(i,j,k) c a(n1+i,j,k)=a(i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) c a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) c tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl peleft) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl peleft) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocx.gt.1) then ! print *,'MPI_Sendrecv E:',mhl,DC_TYPE,peleft,3,peright call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) ! print *,'MPI_Sendrecv F:',mhl,DC_TYPE,peright,4,peleft call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif c c store data in main array now c if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 a( n2+i,j,k)=tmpyrcv1(icnt) c a( n1+i,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) c a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif /* (PARALLEL == 0) */ #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 2',mype #endif return end subroutine update(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE 3',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big c array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=ihr*m1*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) c tmpxrcv2=a(ip(i),m1+ihr-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 end do end do end do do i=1,ihr do j=1,ihr do k=1,l1 tmpcorrcv1=a(ip(n1-ihr+i), j,k) tmpcorrcv2=a(ip(n1-ihr+i),m1+1-j,k) tmpcorrcv3=a(ip(i) ,m1+1-j,k) tmpcorrcv4=a(ip(i) , j,k) a(i-ihr, 1-j,k)=tmpcorrcv1 a(i-ihr,m1+j,k)=tmpcorrcv2 a(n1+i,m1+j,k)=tmpcorrcv3 a(n1+i, 1-j,k)=tmpcorrcv4 end do end do end do #else c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then ! print *,'MPI_Sendrecv A:',nhl,DC_TYPE,peabove,14,13 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv B:',nhl,DC_TYPE,pebelow,11 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then ! print *,'MPI_Sendrecv C:',nhl,DC_TYPE,pebelow,13,14 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv D:',nhl,DC_TYPE,peabove,12 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then ! print *,'MPI_Sendrecv E:',mhl,DC_TYPE,peleft,3,peright call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) ! print *,'MPI_Sendrecv F:',mhl,DC_TYPE,peright,4,peleft call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=1,n1 do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif c--------------------------------------- c now send and receive corner pieces c--------------------------------------- if (nprocx.eq.1) then ! n=mp if (topedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) a(i-ihr,m1+j,k)=a(ip(n1-ihr+i),m1+1-j,k) a(n1+i,m1+j,k)=a(ip(i) ,m1+1-j,k) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) a(i-ihr, 1-j,k)=a(ip(n1-ihr+i),j,k) a(n1+i, 1-j,k)=a(ip(i) ,j,k) icnt=icnt+1 end do end do end do else icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else !nprocx=1 icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if (nprocx.eq.1) then c updates on poles are just done call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #if (SGI_O2K == 2) if (nprocx.eq.1) then c updates on poles are just done call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #else if (nprocx.eq.1) then c updates on poles are just done call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #endif #if (PARALLEL == 2) call mybarrier() if (nprocx.eq.1) then c updates on poles are just done if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocx>1 if (nprocy.gt.1) then if (topedge.eq.1) then ! print *,'MPI_Sendrecv G:',ihl,perightbelow,16,peleftbelow call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv H:',ihl,peleftbelow,17,perightbelow call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv I:',ihl,peleftabove,19,perightabove call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv J:',ihl,perightabove,20,peleftabove call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then ! print *,'MPI_Sendrecv K:',ihl,perightabove,15,peleftabove call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv L:',ihl,peleftabove,18,perightabove call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv M:',ihl,perightbelow,21,peleftbelow call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv N:',ihl,peleftbelow,22,perightbelow call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocy=1 call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) endif !nprocy endif !nprocx ! print *,'MPI_Sendrecv P DONE:' #endif icnt=1 if (nprocx.gt.1) then if (nprocy.gt.1) then if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, -ihr+j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif !nprocy else !nprocx=1 if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,-ihr+j,k)=tmpcorrcv1(icnt) a(n1+i,-ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif endif !nprocx #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 3',mype #endif return end subroutine update2(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE2',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(71) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=m1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below: tmpxsnd1 c prepare top segments for processor above : tmpxsnd2 c------------------------------------------------------------------- c icnt=1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 c a(n1+i,j,k)=a(i,j,k) c a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do #else if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c-------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c-------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then !BOTEDGE call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then !TOPEDGE call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else !MIDDLE call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif !DONE else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(71) #endif #if (DIAGPLT == 1) print *,'UPDATE2 DONE',mype #endif return end subroutine updatebt(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEBT',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(73) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below :tmpxsnd1 c prepare upper data segments for processor above:tmpxsnd2 c------------------------------------------------------------------- c icnt=1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do #else if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #endif #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if(nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if(nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,1-j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(73) #endif #if (DIAGPLT == 1) print *,'UPDATEBT DONE',mype #endif return end subroutine updatelr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATELR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(74) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*m1*l1 #if (PARALLEL == 0) do i=1,ihr do j=1,m1 do k=1,l1 c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do #else if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else c-------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c-------------------------------------------------------------------- icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif c--------------------------------- c store data in main array now c--------------------------------- icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(74) #endif #if (DIAGPLT == 1) print *,'UPDATELR DONE',mype #endif return end #endif /* POLES */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C F U N C T I O N S C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C+++++++++++++++++++++++++ C T I M E function C+++++++++++++++++++++++++ subroutine timefun() include 'param.nml' include 'msg.inc' #if (IBM > 0) character*8 timedat,clock_ #else #if (HP > 0 || WORKS > 0 || FUJI_VPP > 0 || CPQ > 0 || LNX >0 || PLE >0) character*24 timedat #else character*8 timedat #endif #endif if (mype.eq.0) then #if (IBM > 0) timedat= clock_() #else #if (HP > 0 || WORKS > 0 || FUJI_VPP > 0 || CPQ > 0 || LNX >0 || PLE >0) call fdate(timedat) #else call clock(timedat) #endif #endif write(*,*)'*** date: ',timedat end if return end subroutine ttini() parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts do i=1,ntimerb rtimerb(i)=0. rtimer0(i)=0. icounts(i)=0 enddo clabels(1)="main " clabels(2)="initial " clabels(3)="timestep " clabels(4)="moistmod " clabels(5)="timetrans " C-------------------------------- clabels(6)="topolog " clabels(7)="metryc " clabels(8)="tinit " clabels(9)="vstrhat " C-------------------------------- clabels(10)="gcrk " clabels(11)="coef0 " clabels(12)="rhsdiv " clabels(13)="prforc " clabels(14)="precon_df " clabels(15)="precon_bcz" clabels(16)="precon_f " clabels(17)="fourier " clabels(18)="fourieri " clabels(19)="tridg " clabels(20)="spcpri " clabels(21)="laplc " C-------------------------------- clabels(22)="rhngck " clabels(23)="rhotad " clabels(24)="velbc " clabels(25)="vbcad " clabels(26)="transav " clabels(27)="potprs " clabels(28)="zonav " clabels(29)="filstr " C-------------------------------- clabels(30)="advec " clabels(31)="mpdata2 " clabels(32)="mpdatm2 " clabels(33)="mp2bc " clabels(34)="mpdata3 " clabels(35)="mpdatm3 " clabels(36)="mp3bc " clabels(36)="interp " clabels(37)="traject " clabels(38)="trajbc " clabels(39)="velprd " C-------------------------------- clabels(40)="dissip " clabels(41)="stressdv " clabels(42)="strainst " clabels(43)="inject " clabels(44)="normalv " clabels(45)="fckflxdv " clabels(46)="tkefrc " clabels(47)="stress " clabels(48)="lapdf " clabels(49)="rical " C-------------------------------- clabels(50)="pertth " clabels(51)="galin " clabels(52)="cndinst " clabels(53)="cond " clabels(54)="adj_prec " clabels(55)="precip " clabels(56)="rain_fall " clabels(57)="advec1d " clabels(58)="rhfld " clabels(59)="totwrt " C-------------------------------- clabels(60)="diagnos " clabels(61)="lipsch " clabels(62)="drag " clabels(63)="sumcns " clabels(64)="ckcyc " clabels(65)="integz " clabels(66)="filtprf " clabels(67)="noise " clabels(68)="rhfld " clabels(69)=" " C-------------------------------- clabels(70)="update " clabels(71)="update2 " clabels(72)="updatelgr " clabels(73)="updatelr " clabels(74)="updatebt " clabels(75)="updatew " clabels(76)="updatewbt " clabels(77)="updatewlr " clabels(78)="globsum " clabels(79)="globmax " clabels(80)="globmin " C-------------------------------- clabels(81)="iorsh " clabels(82)="ioersh " clabels(83)="ioread " clabels(84)="iowrite " clabels(85)="rdtp " clabels(86)="wrtp " return end subroutine ttbeg(icountnr) integer icountnr real*8, external :: rtc parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts rtimer0(icountnr)=rtc() return end subroutine ttend(icountnr) integer icountnr real*8, external :: rtc parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts rtimerb(icountnr)=rtimerb(icountnr)+(rtc()-rtimer0(icountnr)) icounts(icountnr)=icounts(icountnr)+1 return end subroutine ttprt(rank,iprint) integer i,n,ierr,rank,iptint,nprocs parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts if(rank.eq.iprint) then print *,'Pe #, Item #, Count type, # calls, timer' do i=1,ntimerb if(icounts(i).gt.0) then print 99,rank,i,clabels(i),icounts(i),rtimerb(i) endif if((i.eq.5 ).or.(i.eq.9 ).or.(i.eq.21).or.(i.eq.29).or.(i.eq.39) ..or.(i.eq.49).or.(i.eq.59).or.(i.eq.69).or.(i.eq.80)) . print *,'-------------------------------------------------' enddo ! sort print * print 99,rank, 1,clabels( 1),icounts( 1),rtimerb( 1) print 99,rank, 2,clabels( 2),icounts( 2),rtimerb( 2) print 99,rank, 3,clabels( 3),icounts( 3),rtimerb( 3) print 99,rank, 4,clabels( 4),icounts( 4),rtimerb( 4) print 99,rank, 5,clabels( 5),icounts( 5),rtimerb( 5) print 99,rank,30,clabels(30),icounts(30),rtimerb(30) print 99,rank,40,clabels(40),icounts(40),rtimerb(40) print * rtimerb(1)=0. rtimerb(2)=0. rtimerb(3)=0. rtimerb(4)=0. rtimerb(5)=0. rtimerb(30)=0. 77 continue fmax=0. do i=1,ntimerb temp=rtimerb(i) fmax=max(fmax,temp) enddo if(fmax.gt.0.) then do i=1,ntimerb if(icounts(i).gt.0) then if(fmax.eq.rtimerb(i)) then print 99,rank,i,clabels(i),icounts(i),rtimerb(i) rtimerb(i)=0. goto 77 endif endif enddo endif endif 99 format(1x,i4,1x,i4,4x,a10,2x,i8,1x,f12.4) return end C+++++++++++++++++++++++++ C O T H E R functions C+++++++++++++++++++++++++ integer function find_proc_frn(ipx, ipy,ipz) include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #endif integer :: nprocxy c c Returns the rank of a process given its position in (ipx,ipy,ipz). c c 16-sep-15/ccyang: coded. c c integer :: ipx, ipy, ipz c nprocxy = nprocx_frn*nprocy_frn find_proc_frn = ipz * nprocxy + ipy * nprocx_frn + ipx c end subroutine find_proc_coord(rank, ipx, ipy) include 'param.nml' include 'msg.inc' ! integer :: rank, ipx, ipy ! ipx = mod(rank, nprocx) ipy = rank/nprocx ! end ! C+++++++++++++++++++++++++ #if (WORKS > 0 || IBM > 0 || HP > 0 || PLE > 0 || CPQ > 0 || LNX >0 ) function cvmgmxx(a,b,c) real a,b,c,cvmgmxx if (c.gt.0.) then cvmgmxx = b else cvmgmxx = a endif return end #endif #if (HP > 0 || PLE > 0 || IBM > 0 || CPQ > 0 || LNX >0) Create function for HP/Convex fortran - for comparability with Cray fortran cf77 and cf90 intrinsic functions function shiftl(a,b) integer a,b integer shiftl create bitwise function shiftl(a,b) for fortran on HP/Convex c a=236, b=1, shiftl(a,b)=472 c [ 1, 2, 4, 8, 16, 32, 64,128][256,512, ... ] c a=[ 0, 0, 1, 1, 0, 1, 1, 1][ 0, 0, 0, 0, 0, 0, 0, 0] c shiftl(a,b)=[ 0, 0, 0, 1, 1, 0, 1, 1][ 1, 0, 0, 0, 0, 0, 0, 0] c ---------------------------------------------------------------- c some unix systems have oposite direction of bit raising ! shiftl=a*(2**b) c print *,'shiftl',a,b,bb,shift,shiftl return end function shiftr(a,b) integer a,b integer shiftr create bitwise function shiftr(a,b) for fortran on HP/Convex c a=236, b=1, shiftr(a,b)=118 c [ 1, 2, 4, 8, 16, 32, 64,128][256,512, ... ] c a=[ 0, 0, 1, 1, 0, 1, 1, 1][ 0, 0, 0, 0, 0, 0, 0, 0] c shiftr(a,b)=[ 0, 1, 1, 0, 1, 1, 1, 0][ 0, 0, 0, 0, 0, 0, 0, 0] c ---------------------------------------------------------------- c some unix systems have oposite direction of bit raising ! shiftr=int(a/(2**b)) c print *,'shiftr',a,b,shiftr return end #endif #if (HP > 0) Change above HP to other value if you want use f90 on HP/Convex function xor(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer xor common /msg/ middle,rightedge,leftedge,botedge,topedge,npos,mpos, . perightabove,perightbelow,peleftbelow,peleftabove, . peleft,peright,peabove,pebelow,mype,mysize create bitwise function xor(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c xor(a,b)=[ 1, 0, 0, 0, 1, 1, 0, 0] (49) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte (16 bits) only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 xor=0 c print *,'mype',mype,'a',a c print *,'mype',mype,'b',b do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru xor=xor+abs(aval-bval) enddo c print *,'mype',mype,xor return end function or(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer or create bitwise function or(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c or(a,b)=[ 1, 0, 1, 1, 1, 1, 1, 1] (253) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 or=0 do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru if((aval.ne.0).or.(bval.ne.0)) or=or+2**(i-1) enddo c print *,'or:',or return end function and(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer and create bitwise function and(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c and(a,b)=[ 0, 0, 1, 1, 0, 0, 1, 1] (204) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 and=0 do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru if((aval.ne.0).and.(bval.ne.0)) and=and+2**(i-1) enddo c print *,'and:',and return end #endif #if (GKS == 1) block data blncarg include 'param.nml' c------------------------------------------------------------------------ c---> set frame aspect ratios c---> iautoxz,iautoyz,iautoxy - set aspect ratios of frames c---> = 1 -> aspect ratio = domain size c------------------------------------------------------------------------ common/autogks/ iautoxz,iautoyz,iautoxy data iautoxz/0/,iautoyz/0/,iautoxy/0/ c------------------------------------------------------------------------ c---> is,ie,ksx,kex - number of points to skip from boundary in X,Z frame c---> js,je,ksy,key - Y,Z frame c---> ish,ieh,jsh,jeh - X,Y frame c---> t1x,t2x,t3x,x1z,x2z,x3z - dimension of X,Z frame c---> t1y,t2y,t3y,y1z,y2z,y3z - Y,Z frame c---> t1xh,t2xh,t3xh,t1yh,t2yh,t3yh - X,Y frame c------------------------------------------------------------------------ c---> common/xzfrm/is,ie,t1x,t2x,t3x,ks, ke, t1z,t2z,t3z !inside xzplot common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z data is ,ie ,ksx,kex/ 0, 0, 0, 0/ data t1x,t3x,x1z,x3z/.1,1.,.1,1./ c---> common/yzfrm/js,je,t1y,t2y,t3y,ks ,ke ,t1z,t2z,t3z !inside yzplot common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z data js ,je ,ksy,key/ 0, 0, 0, 0/ data t1y,t3y,y1z,y3z/.1,.5,.1,1./ c---> common/xyfrm/is ,ie ,t1x ,t2x ,t3x ,js ,je ,t1y ,t2y ,t3y !xyplot common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh data ish ,ieh ,jsh ,jeh / 0, 0, 0, 0/ data t1xh,t3xh,t1yh,t3yh/.1,1.,.1,.5/ common/rat/rat1,rat2,rat3 c------------------------------------------------------------------------ c zmin - minimum, zmax - maximum: scale of color vlaues (if izval=1) c these same values for xzplot, yzplot, xyplot c------------------------------------------------------------------------ common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data zmin(1) ,zmax(1) ,izval(1) /0.,0.,0/ !th/the-1. data zmin(2) ,zmax(2) ,izval(2) /0.,0.,0/ !th data zmin(3) ,zmax(3) ,izval(3) /0.,0.,0/ !p*2.*dti data zmin(4) ,zmax(4) ,izval(4) /0.,0.,0/ !u data zmin(5) ,zmax(5) ,izval(5) /0.,0.,0/ !om data zmin(6) ,zmax(6) ,izval(6) /0.,0.,0/ !w data zmin(7) ,zmax(7) ,izval(7) /0.,0.,0/ data zmin(8) ,zmax(8) ,izval(8) /0.,0.,0/ data zmin(9) ,zmax(9) ,izval(9) /0.,0.,0/ !div*dt data zmin(10),zmax(10),izval(10)/0.,0.,0/ !qv [g/kg] data zmin(11),zmax(11),izval(11)/0.,0.,0/ !qc [g/kg] data zmin(12),zmax(12),izval(12)/0.,0.,0/ !qr,qia,qib [g/kg] data zmin(13),zmax(13),izval(13)/0.,0.,0/ !Rh data zmin(14),zmax(14),izval(14)/0.,0.,0/ !thetav data zmin(15),zmax(15),izval(15)/0.,0.,0/ !Km*dt/Dx**2 data zmin(16),zmax(16),izval(16)/0.,0.,0/ !Ri data zmin(17),zmax(17),izval(17)/0.,0.,0/ !v data zmin(18),zmax(18),izval(18)/0.,0.,0/ !vortx*dt data zmin(19),zmax(19),izval(19)/0.,0.,0/ !vorty*dt data zmin(20),zmax(20),izval(20)/0.,0.,0/ !vortz*dt data zmin(21),zmax(21),izval(21)/0.,0.,0/ !pv data zmin(22),zmax(22),izval(22)/0.,0.,0/ !isentropic surface c------------------------------------------------------------------------ c ihlg - high/low label parameters (=0 off) (=1 on) c 0 - off c 1 - hvalue, lvalue c 2 - H(hvalue), L(lvalue) c 3 - H_hvalue, L_lvalue c 4 - H, L c------------------------------------------------------------------------ c ---- XZPLOT --- YZPLOT --- XYPLO ---------- data ihlg(1,1) ,ihlg(2,1) ,ihlg(3,1) /0,0,1/ !th/the-1. data ihlg(1,2) ,ihlg(2,2) ,ihlg(3,2) /0,0,0/ !th data ihlg(1,3) ,ihlg(2,3) ,ihlg(3,3) /1,1,1/ !p*2.*dti data ihlg(1,4) ,ihlg(2,4) ,ihlg(3,4) /2,2,2/ !u data ihlg(1,5) ,ihlg(2,5) ,ihlg(3,5) /3,3,3/ !om data ihlg(1,6) ,ihlg(2,6) ,ihlg(3,6) /4,4,4/ !w data ihlg(1,7) ,ihlg(2,7) ,ihlg(3,7) /0,0,1/ data ihlg(1,8) ,ihlg(2,8) ,ihlg(3,8) /0,0,1/ data ihlg(1,9) ,ihlg(2,9) ,ihlg(3,9) /0,0,1/ !div*dt data ihlg(1,10),ihlg(2,10),ihlg(3,10)/0,0,1/ !qv [g/kg] data ihlg(1,11),ihlg(2,11),ihlg(3,11)/0,0,1/ !qc [g/kg] data ihlg(1,12),ihlg(2,12),ihlg(3,12)/0,0,1/ !qr,qia,qib [g/kg] data ihlg(1,13),ihlg(2,13),ihlg(3,13)/0,0,1/ !Rh data ihlg(1,14),ihlg(2,14),ihlg(3,14)/0,0,1/ !thetav data ihlg(1,15),ihlg(2,15),ihlg(3,15)/0,0,1/ !Km*dt/Dx**2 data ihlg(1,16),ihlg(2,16),ihlg(3,16)/0,0,1/ !Ri data ihlg(1,17),ihlg(2,17),ihlg(3,17)/3,3,3/ !v data ihlg(1,18),ihlg(2,18),ihlg(3,18)/0,0,1/ !vortx*dt data ihlg(1,19),ihlg(2,19),ihlg(3,19)/0,0,1/ !vorty*dt data ihlg(1,20),ihlg(2,20),ihlg(3,20)/0,0,1/ !vortz*dt data ihlg(1,21),ihlg(2,21),ihlg(3,21)/0,0,1/ !pv data ihlg(1,22),ihlg(2,22),ihlg(3,22)/0,0,1/ !isentropic surface c------------------------------------------------------------------------ c ihcg - hachuring flags c 0 - hachuring off c 1 - all contours hachured c 2 - closed contours hachured if interior is downslope, c open contouts all hachured c 3 - closed contours hachured if interior is downslope, c open contouts not hachured c 4 - closed contours hachured if interior is downslope, c open contouts hachured if interior is downslope c -2,-3,-4 like above but "downslope" change to "upslope" c------------------------------------------------------------------------ c XZPLOT YZPLOT XYPLOT data ihcg(1,1) ,ihcg(2,1) ,ihcg(3,1) /0,0,0/ !th/the-1. data ihcg(1,2) ,ihcg(2,2) ,ihcg(3,2) /0,0,0/ !th data ihcg(1,3) ,ihcg(2,3) ,ihcg(3,3) /0,0,0/ !p*2.*dti data ihcg(1,4) ,ihcg(2,4) ,ihcg(3,4) /0,0,2/ !u data ihcg(1,5) ,ihcg(2,5) ,ihcg(3,5) /0,0,2/ !om data ihcg(1,6) ,ihcg(2,6) ,ihcg(3,6) /0,0,2/ !w data ihcg(1,7) ,ihcg(2,7) ,ihcg(3,7) /0,0,0/ data ihcg(1,8) ,ihcg(2,8) ,ihcg(3,8) /0,0,0/ data ihcg(1,9) ,ihcg(2,9) ,ihcg(3,9) /0,0,0/ !div*dt data ihcg(1,10),ihcg(2,10),ihcg(3,10)/0,0,0/ !qv [g/kg] data ihcg(1,11),ihcg(2,11),ihcg(3,11)/0,0,0/ !qc [g/kg] data ihcg(1,12),ihcg(2,12),ihcg(3,12)/0,0,0/ !qr,qia,qib [g/kg] data ihcg(1,13),ihcg(2,13),ihcg(3,13)/0,0,0/ !Rh data ihcg(1,14),ihcg(2,14),ihcg(3,14)/0,0,0/ !thetav data ihcg(1,15),ihcg(2,15),ihcg(3,15)/0,0,0/ !Km*dt/Dx**2 data ihcg(1,16),ihcg(2,16),ihcg(3,16)/0,0,0/ !Ri data ihcg(1,17),ihcg(2,17),ihcg(3,17)/0,0,2/ !v data ihcg(1,18),ihcg(2,18),ihcg(3,18)/0,0,0/ !vortx*dt data ihcg(1,19),ihcg(2,19),ihcg(3,19)/0,0,0/ !vorty*dt data ihcg(1,20),ihcg(2,20),ihcg(3,20)/0,0,0/ !vortz*dt data ihcg(1,21),ihcg(2,21),ihcg(3,21)/0,0,0/ !pv data ihcg(1,22),ihcg(2,22),ihcg(3,22)/0,0,0/ !isentropic surface c------------------------------------------------------------------------ create color palete,line labeling and isoline levels c xzcol for XZ, yzcol for YZ, xycol for XY plots chose xzcol,yzcol,xycol(1,...)=value for color palete c value = 1 - red into light blue c 2 - dark blue into yellow c 3 - gray into white c 4 - white into dark gray (linear scale) c 5 - white into dark gray (quadratic scale) c 6 - black into yellow c 7 - red into dark blue c 8 - dark blue into red c 9 - white c 10 - dark blue (violet) <0, red >0; min - max blue, max - max red c 11 - seledin (blue sky) <0, red >0; min - max blue, max - max red c 12 - seledin (blue water)<0, red >0; min - max blue, max - max red c 13 - dark blue (violet) <0, red >0; max color - amax1(abs(min,max)) c 14 - seledin (blue sky) <0, red >0; max color - amax1(abs(min,max)) c 15 - seledin (blue water)<0, red >0;max color - amax1(abs(min,max)) c 16 - light blue into light red c 17 - new from Vanda Grubisic (59 isolines) c------------------------------------------------------------------------ chose xzcol,yzcol,xycol(2,...)=value for isoline levels (value<=100) c value = 0 - isoline off c n - n isolines between min, max value of ploted array c (if izval=1 - n isolines between zmin, zmax value) c------------------------------------------------------------------------ chose xzcol,yzcol,xycol(3,...)=value for line labels c value = 0 - line labells off c 1 - each line labelled c 2 - each second line labelled c n - n'th line labelled c integer xzcol,yzcol,xycol c------------------------------------------------------------------------ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) c COLORPAL ISOLINES LINE_LABELS data xzcol(1,1) ,xzcol(2,1) ,xzcol(3,1) /4,18,0/ !th/the-1. data xzcol(1,2) ,xzcol(2,2) ,xzcol(3,2) /4,20,0/ !th data xzcol(1,3) ,xzcol(2,3) ,xzcol(3,3) /4,18,0/ !p*2.*dti data xzcol(1,4) ,xzcol(2,4) ,xzcol(3,4) /2,18,0/ !u data xzcol(1,5) ,xzcol(2,5) ,xzcol(3,5) /2,18,0/ !om data xzcol(1,6) ,xzcol(2,6) ,xzcol(3,6) /2,18,0/ !w data xzcol(1,7) ,xzcol(2,7) ,xzcol(3,7) /4,18,0/ data xzcol(1,8) ,xzcol(2,8) ,xzcol(3,8) /4,18,0/ data xzcol(1,9) ,xzcol(2,9) ,xzcol(3,9) /2,18,0/ !div*dt data xzcol(1,10),xzcol(2,10),xzcol(3,10)/4,18,0/ !qv [g/kg] data xzcol(1,11),xzcol(2,11),xzcol(3,11)/4,18,0/ !qc [g/kg] data xzcol(1,12),xzcol(2,12),xzcol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data xzcol(1,13),xzcol(2,13),xzcol(3,13)/4,18,0/ !Rh data xzcol(1,14),xzcol(2,14),xzcol(3,14)/4,18,0/ !thetav data xzcol(1,15),xzcol(2,15),xzcol(3,15)/4,18,0/ !Km*dt/Dx**2 data xzcol(1,16),xzcol(2,16),xzcol(3,16)/4,18,0/ !Ri data xzcol(1,17),xzcol(2,17),xzcol(3,17)/2,18,0/ !v data xzcol(1,18),xzcol(2,18),xzcol(3,18)/2,18,0/ !vortx*dt data xzcol(1,19),xzcol(2,19),xzcol(3,19)/2,18,0/ !vorty*dt data xzcol(1,20),xzcol(2,20),xzcol(3,20)/2,18,0/ !vortz*dt data xzcol(1,21),xzcol(2,21),xzcol(3,21)/2,18,0/ !pv c COLORPAL ISOLINES LINE_LABELS data yzcol(1,1) ,yzcol(2,1) ,yzcol(3,1) /4,18,0/ !th/the-1. data yzcol(1,2) ,yzcol(2,2) ,yzcol(3,2) /4,20,0/ !th data yzcol(1,3) ,yzcol(2,3) ,yzcol(3,3) /4,18,0/ !p*2.*dti data yzcol(1,4) ,yzcol(2,4) ,yzcol(3,4) /2,18,0/ !u data yzcol(1,5) ,yzcol(2,5) ,yzcol(3,5) /2,18,0/ !om data yzcol(1,6) ,yzcol(2,6) ,yzcol(3,6) /2,18,0/ !w data yzcol(1,7) ,yzcol(2,7) ,yzcol(3,7) /4,18,0/ data yzcol(1,8) ,yzcol(2,8) ,yzcol(3,8) /4,18,0/ data yzcol(1,9) ,yzcol(2,9) ,yzcol(3,9) /2,18,0/ !div*dt data yzcol(1,10),yzcol(2,10),yzcol(3,10)/4,18,0/ !qv [g/kg] data yzcol(1,11),yzcol(2,11),yzcol(3,11)/4,18,0/ !qc [g/kg] data yzcol(1,12),yzcol(2,12),yzcol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data yzcol(1,13),yzcol(2,13),yzcol(3,13)/4,18,0/ !Rh data yzcol(1,14),yzcol(2,14),yzcol(3,14)/4,18,0/ !thetav data yzcol(1,15),yzcol(2,15),yzcol(3,15)/4,18,0/ !Km*dt/Dx**2 data yzcol(1,16),yzcol(2,16),yzcol(3,16)/4,18,0/ !Ri data yzcol(1,17),yzcol(2,17),yzcol(3,17)/2,18,0/ !v data yzcol(1,18),yzcol(2,18),yzcol(3,18)/2,18,0/ !vortx*dt data yzcol(1,19),yzcol(2,19),yzcol(3,19)/2,18,0/ !vorty*dt data yzcol(1,20),yzcol(2,20),yzcol(3,20)/2,18,0/ !vortz*dt data yzcol(1,21),yzcol(2,21),yzcol(3,21)/2,18,0/ !pv c COLORPAL ISOLINES LINE_LABELS data xycol(1,1) ,xycol(2,1) ,xycol(3,1) /4,18,0/ !th/the-1. data xycol(1,2) ,xycol(2,2) ,xycol(3,2) /4,20,0/ !th data xycol(1,3) ,xycol(2,3) ,xycol(3,3) /4,18,0/ !p*2.*dti data xycol(1,4) ,xycol(2,4) ,xycol(3,4) /2,18,0/ !u data xycol(1,5) ,xycol(2,5) ,xycol(3,5) /2,18,0/ !om data xycol(1,6) ,xycol(2,6) ,xycol(3,6) /2,18,0/ !w data xycol(1,7) ,xycol(2,7) ,xycol(3,7) /4,18,0/ data xycol(1,8) ,xycol(2,8) ,xycol(3,8) /4,18,0/ data xycol(1,9) ,xycol(2,9) ,xycol(3,9) /2,18,0/ !div*dt data xycol(1,10),xycol(2,10),xycol(3,10)/4,18,0/ !qv [g/kg] data xycol(1,11),xycol(2,11),xycol(3,11)/4,18,0/ !qc [g/kg] data xycol(1,12),xycol(2,12),xycol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data xycol(1,13),xycol(2,13),xycol(3,13)/4,18,0/ !Rh data xycol(1,14),xycol(2,14),xycol(3,14)/4,18,0/ !thetav data xycol(1,15),xycol(2,15),xycol(3,15)/4,18,0/ !Km*dt/Dx**2 data xycol(1,16),xycol(2,16),xycol(3,16)/4,18,0/ !Ri data xycol(1,17),xycol(2,17),xycol(3,17)/2,18,0/ !v data xycol(1,18),xycol(2,18),xycol(3,18)/2,18,0/ !vortx*dt data xycol(1,19),xycol(2,19),xycol(3,19)/2,18,0/ !vorty*dt data xycol(1,20),xycol(2,20),xycol(3,20)/2,18,0/ !vortz*dt data xycol(1,21),xycol(2,21),xycol(3,21)/2,18,0/ !pv data xycol(1,22),xycol(2,22),xycol(3,22)/4,18,0/ !isentropic surface end subroutine ncargdef include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/autogks/iautoxz,iautoyz,iautoxy common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 c nx =n-(is+ie) -1 nzx=l-(ksx+kex)-1 ny =m-(js+je) -1 nzy=l-(ksy+key)-1 nxh=n-(ish+ieh)-1 nyh=m-(jsh+jeh)-1 if (iautoxz.eq.1) then if (((nx)*dx).ge.((nzx)*dz)) then t3x=1. x3z=((nzx)*dz)/((nx)*dx) x1z=0.5-0.4*x3z else t3x=((nx)*dx)/((nzx)*dz) t1x=0.5-0.4*t3x x3z=1. endif endif t2x=t1x+.8*t3x x2z=x1z+.8*x3z if (j3.eq.1) then if (iautoyz.eq.1) then if (((ny)*dy).ge.((nzy)*dz)) then t3y=1. y3z=((nzy)*dz)/((ny)*dy) y1z=0.5-0.4*y3z else t3y=((ny)*dy)/((nzy)*dz) t1y=0.5-0.4*t3y y3z=1. endif endif t2y=t1y+.8*t3y y2z=y1z+.8*y3z if (iautoxy.eq.1) then if (((nxh)*dx).ge.((nyh)*dy)) then t3xh=1. t3yh=((nyh)*dy)/((nxh)*dx) t1yh=0.5-0.4*t3yh else t3xh=((nxh)*dx)/((nyh)*dy) t1xh=0.5-0.4*t3xh t3yh=1. endif endif t2xh=t1xh+.8*t3xh t2yh=t1yh+.8*t3yh endif c nx =n-1 c nzx=l-1 c ny =m-1 c nzy=l-1 c nxh=n-1 c nyh=m-1 rat1=float(nx)*(x2z-x1z)/(float(nzx)*(t2x-t1x)) if (j3.eq.1) then rat2=float(ny)*(y2z-y1z)/(float(nzy)*(t2y-t1y)) rat3=float(nxh)*(t2yh-t1yh)/(float(nyh)*(t2xh-t1xh)) endif ccccccccccccccccccccccccccccccccccccccccccc #if (COLORPL == 1) C define background colors CALL GSCR(1, 0, 1., 1., 1.) !WHITE c CALL GSCR(1, 0, 1., 0., 0.) !RED c CALL GSCR(1, 0, 1., 1., 0.) !YELLOW c CALL GSCR(1, 0, 0., 1., 0.) !GREEN c CALL GSCR(1, 0, 0., 0., 1.) !BLUE c CALL GSCR(1, 0, .5, 1., 0.) !ORANGE c CALL GSCR(1, 0, 0., 1., 1.) !CYAN c CALL GSCR(1, 0, 1., 0., 1.) !MAGENTA c CALL GSCR(1, 0, 0., 0., 0.) !BLACK C define text colors CALL GSCR(1, 1, 0., 0., 0.) !BLACK #else CALL GSCR(1, 0, 0., 0., 0.) !BLACK CALL GSCR(1, 1, 1., 1., 1.) !WHITE #endif ccccccccccccccccccccccccccccccccccccccccccc c set up the text color CALL CPSETI('ILC - INFORMATION LABEL TEXT',1) c set the text color index CALL GSTXCI(1) c set the polyline color index CALL GSPLCI(1) c set the polymarker color index CALL GSPMCI(1) c set the fill area color index CALL GSFACI(1) !foreground CALL GSFACI(0) !background return end #if (PLOTPL == 1) blockdata blplot c----------------------------------------------------- common/plofl/ ibupl,ithpl,iprpl,iuvpl,ivvpl,iwvpl, . ioxpl,ioypl,iozpl,idvpl,ichpl,iripl,iqvpl, . iqcpl,iqrpl,irhpl,ithvpl,ikmpl,iqial,iqibl c ibupl -> dry buoyancy c ithpl -> dry potential temperature c iprpl -> normalized pressure c iuvpl -> zonal wind c ivvpl -> spanwise/meridional wind c iwvpl -> vertical wind c ioxpl -> solenoidal zonal wind c ioypl -> solenoidal spanwise/meridional wind c iozpl -> solenoidal vertical wind c idvpl -> flow divergence*dt c iripl -> Richardson number c iqvpl -> water vapor mixing ratio c iqcpl -> cloud water/ice mixing ratio c iqrpl -> rain/snow water mixing ratio c irhpl -> relative humidity c ithvpl-> moist potential temperature c ikmpl -> c iqipl -> c iqibl -> data ibupl/0/,ithpl/1/,iprpl/1/,iuvpl/1/,ivvpl/1/,iwvpl/1/, 1 ioxpl/0/,ioypl/0/,iozpl/0/,idvpl/0/,ichpl/0/,iripl/0/, 2 iqvpl/0/,iqcpl/0/,iqrpl/0/,irhpl/0/,ithvpl/0/,ikmpl/0/, 3 iqial/0/,iqibl/0/ c----------------------------------------------------- common/plofsl/ ixzpl,iyzpl,ixypl,iznav,isfpl,iprfl,iflxpl,isppl c ixzpl -> plot xz plane contour plots c iyzpl -> plot yz plane contour plots c ixypl -> plot xy plane contour plots c iprfl -> plot 1D horizontally averaged profiles c iflxpl-> plot 1D flux profiles c isppl -> plot 1D power spectra c iznav -> plot zonally averaged yz plane contour plots data ixzpl/1/,iyzpl/1/,ixypl/1/,iznav/0/,isfpl/1/, . iprfl/1/,iflxpl/0/,isppl/0/ c----------------------------------------------------- common/plotxy/ isx,isy,ivctpl,izcr0 data isx,isy/0,0/ ! plot at grid point (0) or between 2 pts (1) c ivctpl = 1 (vectors) c ivctpl = 2 (streamlines) data ivctpl/0/ data izcr0/0/ ! plot 1 vertical level (0) or two (1) common/plotsp/ isptu,isptv,isptw,isptt c declarations for spectrum analysis routine follow; the following arE c for spectral analysis options to be used if isppl = 1 above: c---> isptu = 1 to Fourier analyze u', c---> isptv = 1 for v', c---> isptw = 1 for w', c---> isptt = 1 for theta'. data isptu/1/,isptv/0/,isptw/0/,isptt/0/ c c---> nsppl is number of vertical levels to spectral analyze c---> ksppl(1,2,...nsppl) is vertical grid levels to analyze parameter (nsppl = 9) common/plotsk/ nksppl(nsppl), nkug data nksppl/9*11/ end subroutine plot(th,u,v,w,ox,oy,oz,p,div,chm, * qv,qc,qr,qia,qib,lipps,tke,rhf,tau) c --- th is potential temperture perturbation c --- u,v,w are full zonal, meridional, and vertical wind fields c --- ox, oy, oz are solenoidal? zonal, meridional, and vertical wind c --- fields c --- p,div are pressure perturbation and continuity divergence fields c --- qv,qc,qr are water vapor mixing ratio, cloud water, and c --- precipitating water fields c --- qia,qib are ??? c --- lipps is flag for type of basic state (see subroutine tinit_i) c --- tke is flag for turbulent kinetic energy analysis c --- rhf is Richardson number field include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . div(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . rhf(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . tau(l,1-ih:np+ih,1-ih:mp+ih), . qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) dimension fxz(n,l),fyz(m,l),fxy(n,m),ffz(l), 1 uxz(n,l),wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . scr10(1-ih:np+ih, 1-ih:mp+ih, l, 10) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 3) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/sgscnst/ ceps,cL,cm,cs,prndt common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/stresd/ diagstr(8),ivis,irid,itstr common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/gora/ xml,yml,amp,xml0,yml0,angle common/plzsmax/ zsmx,mintop common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common blocks defined in block data 'blplot' common/plofl/ ibupl,ithpl,iprpl,iuvpl,ivvpl,iwvpl, . ioxpl,ioypl,iozpl,idvpl,ichpl,iripl,iqvpl, . iqcpl,iqrpl,irhpl,ithvpl,ikmpl,iqial,iqibl common/plofsl/ ixzpl,iyzpl,ixypl,iznav,isfpl,iprfl,iflxpl,isppl common/plotxy/ isx,isy,ivctpl,izcr0 common/plotsp/ isptu,isptv,isptw,isptt parameter (nsppl = 9) !same value as in block data 'blplot' common/plotsk/ nksppl(nsppl), nkug common blocks defined in block data 'blncarg' common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- initializations nm=n*m nml=n*m*l n1=n n2=m n3=l inorm=0 if(j3.eq.0) then iyzpl=0 ixypl=0 isy=0 if(icorio.eq.0) ivvpl=0 endif iqvpl=iqvpl*moist iqcpl=iqcpl*moist iqrpl=iqrpl*moist irhpl=irhpl*moist ithvpl=ithvpl*moist ikmpl=ikmpl*ivis iripl=iripl*irid isfpl=isfpl*isphere if(ikmpl.eq.1) then if(j3.eq.1) deltl=1.*(dx+dy+dz)/3. if(j3.eq.0) deltl=sqrt(dx*dz) deltc=sqrt(dx**2+j3*dy**2+dz**2) endif ichpl=ichpl*ichm iqial=(iqial*moist)*iceab iqibl=(iqibl*moist)*iceab contour level density nclv=41 nclvs=61 conversions for displays c limit Ri for display purposes if(iripl.eq.1) then ricut=0. do k=1,l do j=1,m do i=1,n ri(i,j,k)=amin1(ri(i,j,k),ricut) enddo enddo enddo endif c filter selected fields for plots ! WARNING: alters p array nullfl=0 if(nullfl.eq.1) then if(iprpl.eq.1) call filtplt( p,fxyz,df,hx,hy,hz,pz) if(idvpl.eq.1) call filtplt(div,fxyz,df,hx,hy,hz,pz) endif iprint=0 if(iprint.eq.1) then c------------------------------------------------------------- c 1 2 3 4 5 6 7 c23456789012345678901234567890123456789012345678901234567890123456789012 c------------------------------------------------------------- print*,'ithpl,iprpl,iuvpl,ivvpl=',ithpl,iprpl,iuvpl,ivvpl print*,'iwvpl,iozpl,idvpl,ichpl=',iwvpl,iozpl,idvpl,ichpl print*,'iqvpl,iqcpl,iqrpl=',iqvpl,iqcpl,iqrpl print*,'iqial,iqibl=',iqial,iqibl print*,'irhpl,ithvpl,ikmpl,iripl=',irhpl,ithvpl,ikmpl,iripl end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c------ compute and plot (x,y) averaged profiles if(iprfl.eq.1) then if(ibupl.eq.1) then do 101 k=1,l do 101 j=1,m do 101 i=1,n c 101 fxyz(i,j,k)= th(i,j,k)/th0(i,j,k) 101 fxyz(i,j,k)= th(i,j,k) call profil(fxyz,n,m,l,1) endif if(ithpl.eq.1) then do 102 k=1,l do 102 j=1,m do 102 i=1,n 102 fxyz(i,j,k)= th(i,j,k)+the(i,j,k) call profil(fxyz,n,m,l,2) endif if(iprpl.eq.1) then do 103 k=1,l do 103 j=1,m do 103 i=1,n 103 fxyz(i,j,k)= p(i,j,k)*2.*dti call profil(fxyz,n,m,l,3) endif if(iuvpl.eq.1) then do 104 k=1,l do 104 j=1,m do 104 i=1,n 104 fxyz(i,j,k)= u(i,j,k) call profil(fxyz,n,m,l,4) endif if(ivvpl.eq.1) then do 1041 k=1,l do 1041 j=1,m do 1041 i=1,n 1041 fxyz(i,j,k)= v(i,j,k) call profil(fxyz,n,m,l,41) endif if(iozpl.eq.1) then do 105 k=1,l do 105 j=1,m do 105 i=1,n 105 fxyz(i,j,k)= oz(i,j,k) call profil(fxyz,n,m,l,5) endif if(iwvpl.eq.1) then do 106 k=1,l do 106 j=1,m do 106 i=1,n 106 fxyz(i,j,k)= w(i,j,k) call profil(fxyz,n,m,l,6) endif if(idvpl.eq.1) then do 109 k=1,l do 109 j=1,m do 109 i=1,n 109 fxyz(i,j,k)= div(i,j,k)*dt call profil(fxyz,n,m,l,9) endif if(iqvpl.eq.1) then do 110 k=1,l do 110 j=1,m do 110 i=1,n 110 fxyz(i,j,k)= qv(i,j,k)*1.e3 call profil(fxyz,n,m,l,10) endif if(iqcpl.eq.1) then do 111 k=1,l do 111 j=1,m do 111 i=1,n 111 fxyz(i,j,k)= qc(i,j,k)*1.e3 call profil(fxyz,n,m,l,11) endif if(iqrpl.eq.1) then do 112 k=1,l do 112 j=1,m do 112 i=1,n 112 fxyz(i,j,k)= qr(i,j,k)*1.e3 call profil(fxyz,n,m,l,12) endif if(iqial.eq.1) then do 1121 k=1,l do 1121 j=1,m do 1121 i=1,n 1121 fxyz(i,j,k)= qia(i,j,k)*1.e3 call profil(fxyz,n,m,l,31) endif if(iqibl.eq.1) then do 1122 k=1,l do 1122 j=1,m do 1122 i=1,n 1122 fxyz(i,j,k)= qib(i,j,k)*1.e3 call profil(fxyz,n,m,l,32) endif if(irhpl.eq.1) then do 113 k=1,l do 113 j=1,m do 113 i=1,n 113 fxyz(i,j,k)=rhf(i,j,k) call profil(fxyz,n,m,l,13) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 114 k=1,l do 114 j=1,m do 114 i=1,n 114 fxyz(i,j,k)=th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) call profil(fxyz,n,m,l,14) endif if(ikmpl.eq.1) then do 115 k=1,l do 115 j=1,m do 115 i=1,n coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/gi(i,j),zo(i,j)),deltl) 115 fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 call profil(fxyz,n,m,l,15) endif if(iripl.eq.1) then do 116 k=1,l do 116 j=1,m do 116 i=1,n 116 fxyz(i,j,k)=ri(i,j,k) call profil(fxyz,n,m,l,16) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 117 k=1,l do 117 j=1,m do 117 i=1,n 117 fxyz(i,j,k)=chm(i,j,k,ispc) call profil(fxyz,n,m,l,ifsp) enddo endif endif close profiles if(iflxpl.eq.1) then if(iuvpl.eq.1) call reystress( u,w,n,m,l,1,lipps) if(ivvpl.eq.1) call reystress( v,w,n,m,l,2,lipps) if(ithpl.eq.1) call reystress(th,w,n,m,l,3,lipps) if(iqvpl.eq.1) call reystress(qv,w,n,m,l,4,lipps) if(iqcpl.eq.1) call reystress(qc,w,n,m,l,5,lipps) endif close flux profiles cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc contour plots follow zsmx=0. mintop=1.e-4 do j=1,m do i=1,n zsmx=amax1(zsmx,abs(zs(i,j))) enddo enddo c---------------------------------------------------------------- if(ixzpl.eq.1) then ! plot xz-planes pi=acos(-1.) jc=pi*(1/6.+.5)*rds*dyi+0.5 !special for Wmson hill c jc=(1+m)/2 j1=jc jm=jc ji=1 do 777 j=j1,jm,ji do 200 k=1,l do 200 i=1,n uxz(i,k)=0.5*(u(i,j,k)+u(i,j+isy,k)) 200 wxz(i,k)=0.5*(w(i,j,k)+w(i,j+isy,k))*(2-ivctpl) . +0.5*(oz(i,j,k)+oz(i,j+isy,k))*(ivctpl-1) do 1017 k=1,l do 1017 i=1,n xnor0=sqrt(wxz(i,k)**2+uxz(i,k)**2) wxz(i,k)=wxz(i,k)*dx*dzi*rat1 xnort=sqrt(wxz(i,k)**2+uxz(i,k)**2) xcos=uxz(i,k)/(xnort+1.e-15) xsin=wxz(i,k)/(xnort+1.e-15) uxz(i,k)=xnor0*xcos wxz(i,k)=xnor0*xsin 1017 continue if(ibupl.eq.1) then do 201 k=1,l do 201 i=1,n fxz(i,k)=( th(i,j,k)+ th(i,j+isy,k)) c . /(th0(i,j,k)+th0(i,j+isy,k)) 201 continue call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 ! plot log(theta) do k=1,l do i=1,n if(ilog.eq.1) then fxz(i,k)= alog(0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i,j+isy,k)+the(i,j+isy,k))) else fxz(i,k)= 0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i,j+isy,k)+the(i,j+isy,k)) end if end do end do c nclvs=2*nclv call xzplot(j,isy,fxz,uxz,wxz,n,l,0,2,nclvs) endif if(iprpl.eq.1) then do 203 k=1,l do 203 i=1,n fxz(i,k)=p(i,j,k)*2.*dti if(isy.eq.1) then fxz(i,k)=.5*(fxz(i,k)+p(i,j+1,k )*2.*dti) endif 203 continue call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 204 k=1,l do 204 i=1,n 204 fxz(i,k)=.5*(u(i,j,k)+u(i,j+isy,k)) c 204 fxz(i,k)=.5*((u(i,j,k)+u(i,j+isy,k))-(ue(i,j,k)+ue(i,j+isy,k))) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 2041 k=1,l do 2041 i=1,n 2041 fxz(i,k)=.5*((v(i,j,k)+v(i,j+isy,k))-(ve(i,j,k)+ve(i,j+isy,k))) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,41,nclv) endif if(iozpl.eq.1) then do 205 k=1,l do 205 i=1,n 205 fxz(i,k)=.5*(oz(i,j,k)+oz(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,5,nclv) endif if(iwvpl.eq.1) then do 206 k=1,l do 206 i=1,n 206 fxz(i,k)=.5*(w(i,j,k)+w(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 209 k=1,l do 209 i=1,n 209 fxz(i,k)=.5*(div(i,j,k)+div(i,j+isy,k))*dt call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,9,nclv) endif if(iqvpl.eq.1) then do 210 k=1,l do 210 i=1,n 210 fxz(i,k)=.5*(qv(i,j,k)+qv(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,10,nclv) endif if(iqcpl.eq.1) then do 211 k=1,l do 211 i=1,n 211 fxz(i,k)=.5*(qc(i,j,k)+qc(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,11,nclv) endif if(iqrpl.eq.1) then do 212 k=1,l do 212 i=1,n 212 fxz(i,k)=.5*(qr(i,j,k)+qr(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,12,nclv) endif if(iqial.eq.1) then do 2121 k=1,l do 2121 i=1,n 2121 fxz(i,k)=.5*(qia(i,j,k)+qia(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,31,nclv) endif if(iqibl.eq.1) then do 2122 k=1,l do 2122 i=1,n 2122 fxz(i,k)=.5*(qib(i,j,k)+qib(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,32,nclv) endif if(irhpl.eq.1) then do 213 k=1,l do 213 i=1,n 213 fxz(i,k)=.5*(rhf(i,j,k)+rhf(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 214 k=1,l do 214 i=1,n 214 fxz(i,k)=0.5*(th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)* . th0(i,j,k)+th(i,j+isy,k)+the(i,j+isy,k)+ . epsb*qv(i,j+isy,k)*th0(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,14,nclv) endif if(ikmpl.eq.1) then do 215 k=1,l do 215 i=1,n giav=0.5*(gi(i,j)+gi(i,j+isy)) c zoav=0.5*(zo(i,j)+zo(i,j+isy)) coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/giav,deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/giav,zoav),deltl) tkeav=.5*(tke(i,j,k)+tke(i,j+isy,k)) 215 fxz(i,k)=coef*tkeav*dt/deltc**2 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,15,nclv) endif if(iripl.eq.1) then do 216 k=1,l do 216 i=1,n 216 fxz(i,k)=.5*(ri(i,j,k)+ri(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,16,nclv) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 217 k=1,l do 217 i=1,n 217 fxz(i,k)=.5*(chm(i,j,k,ispc)+chm(i,j+isy,k,ispc)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,ifsp,nclv) enddo endif 777 continue endif close xzplots c---------------------------------------------------------------- if(iyzpl.eq.1) then ! plot yz-planes pi=acos(-1.) ic=1.5*pi*rds*dxi+1. !special for Wmsn hill c ic=(n+1)/2 i1=ic in=ic ii=ic do 888 i=i1,in,ii do 300 k=1,l do 300 j=1,m vyz(j,k)=0.5*(v(i,j,k)+v(i+isx,j,k)) 300 wyz(j,k)=0.5*(w(i,j,k)+w(i+isx,j,k))*(2-ivctpl) . +0.5*(oz(i,j,k)+oz(i+isx,j,k))*(ivctpl-1) do 2017 k=1,l do 2017 j=1,m xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi*rat2 xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xcos=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 2017 wyz(j,k)=xnor0*xsin if(ibupl.eq.1) then do 301 k=1,l do 301 j=1,m fyz(j,k)=( th(i,j,k)+ th(i+isx,j,k)) C . /(th0(i,j,k)+th0(i+isx,j,k)) 301 continue call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 ! plot log(theta) do k=1,l do j=1,m if(ilog.eq.1) then fyz(j,k)= alog(0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i+isx,j,k)+the(i+isx,j,k))) else fyz(j,k)= 0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i+isx,j,k)+the(i+isx,j,k)) end if end do end do c nclvs=3*nclv call yzplot(i,isx,fyz,vyz,wyz,m,l,0,2,nclvs) endif iprint=0 if(iprint.eq.1) then print*,'E2:plot' print*,'i,isx,nclvs=',i,isx,nclvs write(6,666) (fyz(16,k),k=1,l) write(6,666) (fyz(j,16),j=1,m) write(6,666) (vyz(16,k),k=1,l) write(6,666) (vyz(j,16),j=1,m) write(6,666) (wyz(16,k),k=1,l) write(6,666) (wyz(j,16),j=1,m) end if 666 format(2x,10(e15.7,1x)) if(iprpl.eq.1) then do 303 k=1,l do 303 j=1,m fyz(j,k)=p(i,j,k)*2.*dti if(isx.eq.1) then fyz(j,k)=.5*(fyz(j,k)+p(i+1,j,k)*2.*dti) endif 303 continue call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 304 k=1,l do 304 j=1,m 304 fyz(j,k)=.5*((u(i,j,k)+u(i+isx,j,k))-(ue(i,j,k)+ue(i+isx,j,k))) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 3041 k=1,l do 3041 j=1,m 3041 fyz(j,k)=.5*((v(i,j,k)+v(i+isx,j,k))-(ve(i,j,k)+ve(i+isx,j,k))) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,41,nclv) endif if(iozpl.eq.1) then do 305 k=1,l do 305 j=1,m 305 fyz(j,k)=.5*(oz(i,j,k)+oz(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,5,nclv) endif if(iwvpl.eq.1) then do 306 k=1,l do 306 j=1,m 306 fyz(j,k)=.5*(w(i,j,k)+w(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 309 k=1,l do 309 j=1,m 309 fyz(j,k)=.5*(div(i,j,k)+div(i+isx,j,k))*dt call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,9,nclv) endif if(iqvpl.eq.1) then do 310 k=1,l do 310 j=1,m 310 fyz(j,k)=.5*(qv(i,j,k)+qv(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,10,nclv) endif if(iqcpl.eq.1) then do 311 k=1,l do 311 j=1,m 311 fyz(j,k)=.5*(qc(i,j,k)+qc(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,11,nclv) endif if(iqrpl.eq.1) then do 312 k=1,l do 312 j=1,m 312 fyz(j,k)=.5*(qr(i,j,k)+qr(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,12,nclv) endif if(iqial.eq.1) then do 3121 k=1,l do 3121 j=1,m 3121 fyz(j,k)=.5*(qia(i,j,k)+qia(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,31,nclv) endif if(iqibl.eq.1) then do 3122 k=1,l do 3122 j=1,m 3122 fyz(j,k)=.5*(qib(i,j,k)+qib(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,32,nclv) endif if(irhpl.eq.1) then do 313 k=1,l do 313 j=1,m 313 fyz(j,k)=.5*(rhf(i,j,k)+rhf(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 314 k=1,l do 314 j=1,m 314 fyz(j,k)=.5*(th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)* . th0(i,j,k)+th(i+isx,j,k)+the(i+isx,j,k)+ . epsb*qv(i+isx,j,k)*th0(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,14,nclv) endif if(ikmpl.eq.1) then do 315 k=1,l do 315 j=1,m giav=0.5*(gi(i,j)+gi(i+isx,j)) c zoav=0.5*(zo(i,j)+zo(i+isx,j)) coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/giav,deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/giav,zoav),deltl) tkeav=.5*(tke(i,j,k)+tke(i+isx,j,k)) 315 fyz(j,k)=coef*tkeav*dt/deltc**2 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,15,nclv) endif if(iripl.eq.1) then do 316 k=1,l do 316 j=1,m 316 fyz(j,k)=.5*(ri(i,j,k)+ri(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,16,nclv) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 317 k=1,l do 317 j=1,m 317 fyz(j,k)=.5*(chm(i,j,k,ispc)+chm(i+isx,j,k,ispc)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,ifsp,nclv) enddo endif 888 continue endif close yzplots c---------------------------------------------------------------- if(ixypl.eq.1) then ! plot xy-planes do 998 izcr=0,izcr0 if(izcr.eq.0) then k1=1 kl=11 ki=10 else k1=11 kl=11 ki=1 endif do 999 kk=k1,kl,ki if(ivctpl.eq.1) then call inzxy(kk,u,uxy,n,m,l,izcr,0,nkug) call inzxy(kk,v,vxy,n,m,l,izcr,0,nkug) do 400 j=1,m do 400 i=1,n xnor0=sqrt(uxy(i,j)**2+vxy(i,j)**2) vxy(i,j)=vxy(i,j)*dx*dyi*rat3 xnort=sqrt(uxy(i,j)**2+vxy(i,j)**2) xcos=uxy(i,j)/(xnort+1.e-15) xsin=vxy(i,j)/(xnort+1.e-15) uxy(i,j)=xnor0*xcos 400 vxy(i,j)=xnor0*xsin endif if(ibupl.eq.1) then do 401 i=1,n do 401 j=1,m do 401 k=1,l 401 fxyz(i,j,k)=th(i,j,k) C /th0(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,1,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,1,nclv) endif if(ithpl.eq.1) then do i=1,n do j=1,m do k=1,l ilog=0 ! plot log(theta) if(ilog.eq.1) then fxyz(i,j,k)= alog(th(i,j,k)+the(i,j,k)) else fxyz(i,j,k)= th(i,j,k)+the(i,j,k) end if end do end do end do c nclvs=2*nclv call inzxy(kk,th,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,2,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,2,nclv) endif if(iprpl.eq.1) then do 403 i=1,n do 403 j=1,m do 403 k=1,l 403 fxyz(i,j,k)=p(i,j,k)*2.*dti call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,3,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,3,nclv) endif if(iuvpl.eq.1) then do 404 i=1,n do 404 j=1,m do 404 k=1,l 404 fxyz(i,j,k)= u(i,j,k)-ue(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,4,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,4,nclv) endif if(ivvpl.eq.1) then do 4041 i=1,n do 4041 j=1,m do 4041 k=1,l 4041 fxyz(i,j,k)= v(i,j,k)-ve(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,41,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,41,nclv) endif if(iozpl.eq.1) then call inzxy(kk,om,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,5,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,5,nclv) endif if(iwvpl.eq.1) then call inzxy(kk,w,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,6,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,6,nclv) endif if(idvpl.eq.1) then do 409 i=1,n do 409 j=1,m do 409 k=1,l 409 fxyz(i,j,k)= div(i,j,k)*dt call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,9,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,9,nclv) endif if(iqvpl.eq.1) then do 410 i=1,n do 410 j=1,m do 410 k=1,l 410 fxyz(i,j,k)=qv(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,10,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,10,nclv) endif if(iqcpl.eq.1) then do 411 i=1,n do 411 j=1,m do 411 k=1,l 411 fxyz(i,j,k)=qc(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,11,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,11,nclv) endif if(iqrpl.eq.1) then do 412 i=1,n do 412 j=1,m do 412 k=1,l 412 fxyz(i,j,k)=qr(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,12,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,12,nclv) endif if(iqial.eq.1) then do 4121 i=1,n do 4121 j=1,m do 4121 k=1,l 4121 fxyz(i,j,k)=qia(i,j,k)*1.e3 call inzxy(k,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,31,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,31,nclv) endif if(iqibl.eq.1) then do 4122 i=1,n do 4122 j=1,m do 4122 k=1,l 4122 fxyz(i,j,k)=qib(i,j,k)*1.e3 call inzxy(k,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,32,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,32,nclv) endif if(irhpl.eq.1) then call inzxy(kk,rhf,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,13,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 414 i=1,n do 414 j=1,m do 414 k=1,l 414 fxyz(i,j,k)=th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,14,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,14,nclv) endif if(ikmpl.eq.1) then do 415 k=1,l do 415 i=1,n do 415 j=1,m coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/gi(i,j),zo(i,j)),deltl) 415 fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,15,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,15,nclv) endif if(iripl.eq.1) then call inzxy(kk,ri,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,16,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,16,nclv) endif if(ichpl.eq.1) then do ispc=3,nspc ifsp=16+ispc do 417 i=1,n do 417 j=1,m do 417 k=1,l 417 fxyz(i,j,k)=chm(i,j,k,ispc) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,ifsp,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,ifsp,nclv) enddo endif 999 continue 998 continue close xyplot endif if(iznav.eq.1) then call zonav(v,vyz,tau,0) call zonav(w,wyz,tau,0) do 5017 k=1,n3 do 5017 j=1,n2 xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xco=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 5017 wyz(j,k)=xnor0*xsin if(ibupl.eq.1) then do 501 k=1,n3 do 501 j=1,n2 do 501 i=1,n1 501 fxyz(i,j,k)=th(i,j,k) C /the(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 do 502 k=1,n3 do 502 j=1,n2 do 502 i=1,n1 if(ilog.eq.1) then fxyz(i,j,k)=alog(th(i,j,k)+the(i,j,k)) else fxyz(i,j,k)= th(i,j,k)+the(i,j,k) endif 502 continue call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,0,2,nclvs) endif if(iprpl.eq.1) then do 503 k=1,n3 kp=min0(k+1,n3) km=max0(k-1,1) do 5031 j=1,n2 jp=min0(j+1,n2) jm=max0(j-1,1) do 5032 i=1,n1 5032 fxyz(i,j,k)=( p(i,jp,k)+2.*p(i,j,k)+p(i,jm,k) 1 +p(i,j,kp)+2.*p(i,j,k)+p(i,j,km) )*.125*2.*dti 5031 continue 503 continue call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 504 k=1,n3 do 504 j=1,n2 do 504 i=1,n1 504 fxyz(i,j,k)=u(i,j,k)-0.*ue(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 5041 k=1,n3 do 5041 j=1,n2 do 5041 i=1,n1 5041 fxyz(i,j,k)=v(i,j,k)-0.*ve(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,41,nclv) endif if(iwvpl.eq.1) then do 5061 k=1,n3 do 5061 j=1,n2 do 5061 i=1,n1 5061 fxyz(i,j,k)=w(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 5091 k=1,n3 do 5091 j=1,n2 do 5091 i=1,n1 5091 fxyz(i,j,k)=div(i,j,k)*dt call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,9,nclv) endif endif close zaplots c call spectral_phys(u,v,w) !---------------> jad spectra c---------------------------------------------------------------- #if (SPCTPL == 1) c --- Perform spectral analysis on xy planes. Individual 1d c --- spectra are averaged in y for each x line on the specifed c --- plane. Output parameter kug from subroutine inzxy defines c --- underground points which are either avoided or set to zero c --- in this analysis. if((tt.gt.0.) .and. (isppl.eq.1)) then c plot vertical spectrum, at every 80th point if (isptu.eq.1) then do i=1,n,32 do j=1,m c exclude sponge c do k=1,168 do k=1,l ffz(k)= u(i,j,k)-ue(i,j,k) enddo c do the spectral analysis outside write(20) ffz c call specz(ffz,168,i,1) enddo enddo endif do 1098 izcr=0,izcr0 do 510 kk=1,nsppl c do 510 ks=1,l ks = nksppl(kk) if((ks.gt.0) .and. (ks.le.L)) then if(isptu.eq.1) then do 505 i=1,n do 505 j=1,m do 505 k=1,l fxyz(i,j,k)= u(i,j,k)-ue(i,j,k) 505 continue c special power spectrum call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,1,ks,nkug,i) enddo endif if(isptv.eq.1) then do 506 i=1,n do 506 j=1,m do 506 k=1,l fxyz(i,j,k)= v(i,j,k)-ve(i,j,k) 506 continue call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,2,ks,nkug,i) enddo endif if(isptw.eq.1) then call inzxy(ks,w,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,3,ks,nkug,i) enddo endif if(isptt.eq.1) then do 508 i=1,n do 508 j=1,m do 508 k=1,l c fxyz(i,j,k)=th(i,j,k)/the(i,j,k)-1. fxyz(i,j,k)=th(i,j,k) 508 continue call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,4,ks,nkug,i) enddo endif endif 510 continue 1098 continue endif close spectral analysis #endif return end #if (SPCTPL == 1) subroutine spec0(f,n1,n2,k,iflg) dimension f(n1,n2) include 'param.nml' parameter(nm=n-1,nns=nm/2,nnp=nns+1) dimension spc(nnp,m),xx(nnp),a(nnp),b(nnp),cc(nnp), . spav(nnp),re53(nnp) data cc/nnp*2./ character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 pi=acos(-1.) pi2=2.*pi xnm=1./float(nm) cc(1)=1. cc(nnp)=1. do kk=2,nnp xx(kk)=alog10(float(kk-1)) enddo xmn=0. xmx=float( int(xx(nnp)+1.) ) do 1 j=1,m-1 do jj=1,nnp a(jj)=0. b(jj)=0. do ii=1,nm a(jj)=a(jj)+f(ii,j)*cos(pi2*(ii-1)*(jj-1)*xnm)*xnm b(jj)=b(jj)-f(ii,j)*sin(pi2*(ii-1)*(jj-1)*xnm)*xnm enddo enddo do kk=1,nnp spc(kk,j)=cc(kk)*(a(kk)**2+b(kk)**2) enddo 1 continue do kk=2,nnp spav(kk)=0. do j=1,m-1 spav(kk)=spav(kk)+spc(kk,j)/float(m-1) enddo enddo do kk=2,nnp spav(kk)=alog10(spav(kk)) enddo do j=1,m-1 spmn= 1.e15 spmx=-1.e15 do kk=2,nnp spc(kk,j)=alog10(spc(kk,j)) spmn=amin1(spmn,spc(kk,j)) spmx=amax1(spmx,spc(kk,j)) enddo spmn=int(spmn-1.) spmx=int(spmx+1.) enddo #if (GKS == 1) call set(.1,.9,.1,.9,xmn,xmx,spmn,spmx,1) ipt1=int(192.8+819.2) call gaseti('LTY',1) if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time if(iflg.eq.3) write (lhead,103) time if(iflg.eq.4) write (lhead,104) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:37),0.015,0.,0.) call labmod('(f3.0)','(f5.0)',4,4,2,2,20,20,0) ix=int(xmx-xmn) iy=int(spmx-spmn) call periml(ix,1,iy,1) c call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) c do j=1,m-1 c call curved(xx(2),spc(2,j),nns) c enddo call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xx(2),spav(2),nns) re53(2)=spmx c53=5./3. do kk=3,nnp re53(kk)=amax1(spmn, re53(kk-1)-c53*(xx(kk)-xx(kk-1))) enddo call curved(xx(2),re53(2),nns) call setusv('LW',1000) i1=int(102.4+409.6) call plchhq(cpux(i1),cpuy(50),'log k',0.015,0.,0.) call plchhq(cpux(17),cpuy(i1),'log P',0.015,90.,0.) call frame #endif 101 format(' at time= ',f9.2) 102 format(' at time= ',f9.2) 103 format(' at time= ',f9.2) 104 format(' at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine spxypl(fxy, n1, n2, iflg, k, nkug,dsd) c --- Performs spectral analysis of 2D input data array fxy(n1,n2) c --- at grid level k. iflg is an input flag indentifing the field c --- contained in fxy (1=u',2=v',3=w',4=theta'). If underground c --- points exist in the input Cartesian xy plane at level k they c --- are identified by the input value of kug in the appropriate c --- location of the array. c include 'param.nml' integer nmax, numdim c --- set nmax=max(n,m) parameter (nmax=n) parameter (numdim=2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm C --- Load the SRFACE common block COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , 1 IDRY ,IDRZ ,IUPPER ,ISKIRT , 2 NCLA ,THETA ,HSKIRT ,CHI , 3 CLO ,CINC ,ISPVAL c --- input parameter declarations real fxy(n,m) c --- local declarations real fx(nmax), a(nmax), b(nmax), kx(nmax), e(nmax), yyp(nmax), 1 avex(nmax), esum(nmax), varx(nmax), xp(nmax), yp(nmax), 2 sdom(nmax), sig(nmax) real ej(nmax,nmax), wsave(4*nmax+15), cr(nmax), ci(nmax) complex c(nmax) real avexy, varxy, ex, sigx, emax, kmax, emin, kmin, varf, 1 varxyy, zkm, twopi integer np, npx, npxy, npy, s1, s2, s2x, s2y, ns, nwork integer i,ii,j,jj,ix,jy,ndim,nd2,nd2p1,s,ixmin,ixmax,jymax, 1 kk, n1d2, n1d2p1, n2d2, n2d2p1, isize integer imin,imax,jmin,jmax,mjrx,mnrx,mjry,mnry,exfmt,eyfmt real del,xlen,xmin,xmax,xlmin,xlmax,ymin,ymax,ylmin,ylmax, 1 xx, yy, zz, cpux, cpuy real slope, xs(2), ys(2) real afit,bfit,ss,st2,sx,sxoss,sy,t real eye(6), stereo integer nns(numdim), ntot, isign, iform, nx, ny, ierr complex work(2*nmax*nmax) real data1((n+2)*m), dkk, dkk1 character*80 title real UL, UR, UB, UT, UX, UY parameter (twopi=6.283185307179586476925286766559) c The following data statements control execution of the spectrum c analysis and provide for plotting options. c dsd - A flag to indicate the type of spectrum to compute. c If dsd =1 1D spectra are computed along the direction of c the first index of fxy, and if dsd=2 the 1D spectra is c computed along the direction of the second index of fxy. c These 1D spectra will averaged in the direction normal to c dsd for output. Otherwise, if dsd ne 1 or 2, a 2D spectrum c is computed and output. c ireset - Set ireset=1 to reset underground values to zero, and c perform Fourier analysis with these zero values included. c Otherwise, if ireset ne 1 the furthest unobstructed c downstream location is determined and only those locations c downstream are Fourier analyzed. c subavg - A flag indicating that the horizontal average of the data c is to be subtracted out before computing the spectrum. c escale - Contols scaling of the resulting spectrum for the plots. c If escale =1, the spectrum is scaled by the variance, by the c variance divided by the wavenumber if escale =2, by wstar**2 c if escale=3, or by Tstar**2 if escale =4. Otherwise no scaling c is performed. c krad - Controls wavenumber definition. If krad=1, wavenumbers c are angular in units of radians/m, otherwise linear in c cylces/m. c kscale - Controls scaling of wavenumber axis for the plots. The c the wavenumber scaled by the domain length in the dsd c direction if kscale=1, or scaled by zi if kscale=2. c Otherwise it is dimensional in units dependent on krad. c LL - Contols log-linear plotting according to NCAR graphics c conventions (LL=1 is linear x and y, LL=2 is linear x, c log y, LL=3 is log x, linear y, LL=4 is log x, log y). c iprint - Set iprint ge 1 to get printed output. c ndec - The number of decades to plot on log-log plots. c plot0 - Set =1 to plot 0 wavenumber. c plotny - Set=1 to plot Nyquist wavenumber (i.e. 2dx). c plotrf - Set=1 to plot reference line of slope on log-log plots, c where setting islope=1 gives -5/3, islope=2 gives -3. c plotsd - Set=1 to plot +/- one sigma deviation from the mean c of the 1D spectra. integer dsd, ireset, subavg, krad, kscale, escale, LL, 1 iprint, ndec, plot0, plotny, plotrf, islope, plotsd data ireset/1/, subavg/0/, escale/3/, kscale/2/, krad/1/, 1 LL/4/, iprint/0/, ndec/2/, plot0/0/, plotny/1/, plotrf/1/, 2 islope/1/, plotsd/0/ common/srprint/ itblpri c if(dsd.eq.0) then call spec0(fxy,n1,n2,k,iflg) return endif c --- print inputs if(iprint.ge.1) then print *,'n1,n2,iflg,k,dsd,nkug,ireset,LL,subavg,kscale,escale=', 1 n1,n2,iflg,k,dsd,nkug,ireset,LL,subavg,kscale,escale if(iprint.ge.3) then do 555 i=1,n1 write(6,222) (fxy(i,j),j=1,n2) 555 continue endif endif c c --- do some consistency checks if(iflg.le.3) escale=3 if(iflg.eq.4) escale=4 if((j3.eq.0).and.((dsd.ne.1).and.(dsd.ne.2))) dsd=1 if((j3.eq.0).and.(plotsd.ne.0)) plotsd=0 if(plotrf.eq.1) then if(islope.eq.2) then slope = -3. else slope = -5./3. endif endif if((kscale.eq.2) .and. (abs(zi).lt.1.0e-30)) then kscale = 0 elseif((escale.eq.3) .and. (abs(wstr).lt.1.0e-30)) then escale = 0 elseif((escale.eq.4) .and. (abs(tstr).lt.1.0e-30)) then escale = 0 endif c c --- remove underground points from the data. If ireset ne 1 c --- analyze only the dataset resulting from downstream points c --- from the largest index with valid data. ixmin = 0 if(nkug.ne.0) then do 10 j=1,n2 do 10 i=1,n1 if(nint(fxy(i,j)).eq.nkug) then if(ireset.eq.1) then fxy(i,j) = 0. else if(dsd.eq.2) then ixmin = max0(ixmin,j) else ixmin = max0(ixmin,i) endif endif endif C# print *,'j,i,fxy,ixmin =',j,i,nint(fxy(i,j)),ixmin 10 continue endif c --- if cyclic reduce dimension by 1 if(dsd.eq.2) then ixmax = n2-ibcy jymax = n1-ibcx else ixmax = n1-ibcx jymax = n2-ibcy if((dsd.ne.1) .and. ((ixmax/2)*2.ne.ixmax)) then c --- ensure first dimension for 2D spectrum is even ixmax = ixmax-1 endif endif ndim = ixmax - ixmin xlen = float(ndim-1)*dx ixmin = ixmin + 1 nd2 = ndim/2 nd2p1 = nd2 + 1 c if(ndim.le.1) then write(6,110) k return endif if(iprint.ge.1) then print *,'nmax,ixmax,jymax =',nmax,ixmax,jymax print *,'kug,ixmin,ndim,nd2 =',nkug,ixmin,ndim,nd2 print *,'xlen =',xlen endif c c --- compute the mean of the input data on the xy plane avexy = 0. npxy = 0 do 14 jy=1,jymax avex(jy) = 0. npx = 0 do 12 ix=ixmin,ixmax if(dsd.eq.2) then avex(jy) = avex(jy) + fxy(jy,ix) avexy = avexy + avex(jy) else avex(jy) = avex(jy) + fxy(ix,jy) avexy = avexy + avex(jy) endif npx = npx + 1 npxy = npxy + 1 12 continue avex(jy) = avex(jy)/float(npx) 14 continue avexy = avexy/float(npxy) c c --- compute the variance of the input data on the xy plane varxy = 0. npxy = 0 do 16 jy=1,jymax do 15 ix=ixmin,ixmax varxy = varxy + fxy(ix,jy)**2 npxy = npxy + 1 15 continue 16 continue varxy = varxy/float(npxy) c --- check if data is worth further analysis if(varxy.lt.1.0e-30) then write(6,120) iflg, varxy, npxy return endif c if((dsd.eq.1) .or. (dsd.eq.2)) then c --- compute and average 1d spectra c c --- initialize the 1D FFT routines for length ndim. CALL CFFTI (NDIM,WSAVE) c c --- Loop over lines in dsd direction varxyy = 0. npy = 0 do 18 s=1,nd2p1 esum(s) = 0. 18 continue do 50 jy=1,jymax npy = npy+1 c --- form a 1D array of data on each x line do 20 ix=ixmin,ixmax i = ix - ixmin + 1 if(dsd.eq.2) then fx(i) = fxy(jy,ix) else fx(i) = fxy(ix,jy) endif if(subavg.eq.1) then fx(i) = fx(i) - avex(jy) avex(jy) = 0. endif 20 continue c --- compute variance of input data sigx = 0. npx = 0 do 22 ix=ixmin,ixmax i = ix - ixmin + 1 sigx = sigx + fx(i)**2 npx = npx + 1 22 continue varx(jy) = sigx/float(npx) varxyy = varxyy + varx(jy) c c --- perform the FFT on the 1D data do 23 i=1,ndim c(i) = CMPLX(fx(i),0.0) 23 continue CALL CFFTF (NDIM,C,WSAVE) do 24 s=1,nd2p1 cr(s) = REAL(c(s))/ndim ci(s) = -AIMAG(c(s))/ndim 24 continue e(1)= cr(1)**2 + ci(1)**2 e(nd2p1)= cr(nd2p1)**2 + ci(nd2p1)**2 do 25 s=2,nd2 e(s)=2.*(cr(s)**2 + ci(s)**2) 25 continue c c --- form the average and variance varf = 0. do 40 s=1,nd2p1 esum(s) = esum(s) + e(s) ej(jy,s) = e(s) varf = varf + e(s) 40 continue c c --- print out the results if iprint=1 if(iprint.ge.1) then print *,'spectra at j =',jy print *,'avex(j),varx(j),varf =',avex(jy),varx(jy),varf do 45 s=1,nd2p1 write(6,115) s-1,cr(s),ci(s),e(s) 45 continue c if(iprint.ge.2) then c --- test by computing coefficients directly A(1) = 0. A(ND2P1) = 0. DO 33 J=1,NDIM A(1) = A(1) + FX(J) A(ND2P1) = A(ND2P1) + FX(J)*(-1)**J 33 CONTINUE A(1) = A(1)/ND2 A(ND2P1) = A(ND2P1)/ND2 B(1) = 0. B(ND2P1) = 0. DO 36 S=2,ND2 A(S) = 0. B(S) = 0. DO 35 J=1,NDIM T = TWOPI*(S-1)*(J-1)/NDIM A(S) = A(S) + FX(J)*COS(T) B(S) = B(S) + FX(J)*SIN(T) 35 CONTINUE A(S) = A(S)/ND2 B(S) = B(S)/ND2 36 CONTINUE do 37 s=1,nd2p1 print *,'s,a,afft =',s,a(s)/2.,cr(s) print *,'s,b,bfft =',s,b(s)/2.,ci(s) 37 continue c PRINT *,'CHECKING INVERSES' CALL CFFTB (NDIM,C,WSAVE) do 46 i=1,ndim write(6,113) i,fx(i),c(i)/ndim 46 continue endif !iprint.eq.2 endif !iprint.eq.1 c c --- end of j loop 50 continue varxyy = varxyy/float(npy) c if(iprint.ge.3) then PRINT *,'E SUMS' do 47 s=1,ND2P1 write(6,116) s-1,esum(s) 47 continue endif c c --- Now compute the power after appropriate normalization. emin = 1.0e+10 kmin = 1.0e+10 emax = 0. kmax = 0. varf = 0. do 60 s=1,nd2p1 kx(s) = float(s-1) if(krad.eq.1) kx(s) = twopi*kx(s) esum(s) = esum(s)/jymax e(s) = esum(s) varf = varf + esum(s) emin = amin1(emin,e(s)) kmin = amin1(kmin,kx(s)) emax = amax1(emax,e(s)) kmax = amax1(kmax,kx(s)) 60 continue c if(iprint.ge.1) then print *,'npxy,avexy,varxy,varxyy,varf =',npxy,avexy, 1 varxy,varxyy,varf print *,'LL,emin,emax,kmin,kmax =',LL,emin,emax,kmin,kmax do 64 s=1,nd2p1 write(6,118) s-1,kx(s),e(s) 64 continue endif c c --- set up values to plot in xp,yp if(plot0.eq.0) then s1=2 else s1=1 endif if(plotny.eq.0) then s2=nd2p1-1 else s2=nd2p1 endif np = s2-s1+1 j = 0 xmax = 0. ymax = 0. do 65 s=s1,s2 j=j+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen xp(j) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi xp(j) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m xp(j) = kx(s)/xlen endif xmax = amax1(xmax,xp(j)) if(escale.eq.1) then yp(j) = e(s)/varxy elseif(escale.eq.2) then yp(j) = e(s)*kx(s)/varxy elseif(escale.eq.3) then yp(j) = e(s)/(wstr**2) ccc yp(j) = kx(s)/xlen*zi*e(s)/(wstr**2) elseif(escale.eq.4) then yp(j) = e(s)/(tstr**2) ccc yp(j) = kx(s)/xlen*zi*e(s)/(tstr**2) else yp(j) = e(s) endif ymax = amax1(ymax,yp(j)) 65 continue np = j c c --- plot the average 1D spectrum at level k on linear or c --- log axes with appropriate scalings determined by escale if((LL.le.1) .or. (LL.gt.4)) then c --- linear x linear y LL=1 exfmt = 0 mnrx = 5 imax = 5 CALL SCALE1(0.,xmax, imax, UL, UR, del, ierr) mjrx = (UR-UL)/del if(abs(del).lt.1.0e-4) exfmt = 1 if(ierr.ne.0) then exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.ge.0.) imax = imax + 1 UL = 0. UR = 10.0**imax mjrx = 5 endif c eyfmt = 0 jmax = 5 CALL SCALE1(0.,ymax, jmax, UB, UT, del, ierr) mjry = (UT-UB)/del if(abs(del).lt.1.0e-4) eyfmt = 1 if(ierr.ne.0) then eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.ge.0.) jmax = jmax + 1 UB = 0. UT = 10.0**jmax mjry = 5 endif mnry = 5 c elseif(LL.eq.2) then c --- linear x log10 y exfmt = 0 mnrx = 5 imax = 5 CALL SCALE1(0.,xmax, imax, UL, UR, del, ierr) mjrx = (UR-UL)/del if(abs(del).lt.1.0e-4) exfmt = 1 if(ierr.ne.0) then exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.ge.0.) imax = imax + 1 UL = 0. UR = 10.0**imax mjrx = 5 endif c jmax = int(alog10(ymax)) + 1 jmin = jmax-ndec UB = 10.0**jmin UT = 10.0**jmax mjry = 1 mnry = 0 eyfmt = 1 c elseif(LL.eq.3) then c --- log10 x linear y exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.gt.0.) imax = imax + 1 xlmin = alog10(xp(1)) imin = int(xlmin) UL = 10.0**imin UR = 10.0**imax mjrx = 1 mnrx = 0 c eyfmt = 0 mnry = 5 jmax = 5 CALL SCALE1(0.,ymax, jmax, UB, UT, del, ierr) mjry = (UT-UB)/del if(abs(del).lt.1.0e-4) eyfmt = 1 if(ierr.ne.0) then eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.ge.0.) jmax = jmax + 1 UB = 0. UT = 10.0**jmax mjry = 5 endif c elseif(LL.eq.4) then c --- log10 x log10 y mjrx = 1 mnrx = 0 exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.gt.0.) imax = imax + 1 imin = imax - ndec UL = 10.0**imin UR = 10.0**imax c mjry = 1 mnry = 0 eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.gt.0.) jmax = jmax + 1 jmin = jmax - ndec UB = 10.0**jmin UT = 10.0**jmax c endif !LL eq 1,2,3,4 c c --- protect against plotting outside plot window do 70 j=1,np xp(j) = amax1(xp(j),UL) xp(j) = amin1(xp(j),UR) yp(j) = amax1(yp(j),UB) yp(j) = amin1(yp(j),UT) 70 continue c if(iprint.ge.2) then print *,'np=',np do 72 j=1,np write(6,119) j, xp(j), yp(j) 72 continue print *,'UL,UR,UB,UT,LL=',UL,UR,UB,UT,LL print *,'imin,imax,jmin,jmax=',imin,imax,jmin,jmax print *,'mjrx,mnrx,mjry,mnry=',mjrx,mnrx,mjry,mnry print *,'exfmt,eyfmt=',exfmt,eyfmt endif c #if (GKS == 1) c --- set up the plot call set(.175,.90,.175,.90,UL,UR,UB,UT,LL) call gaseti('LTY',1) c --- attach a title zkm = float(k-1)*dz/1000. if(iflg.eq.1) write (title,101) time,zkm if(iflg.eq.2) write (title,102) time,zkm if(iflg.eq.3) write (title,103) time,zkm if(iflg.eq.4) write (title,104) time,zkm c print *,'title =',title(1:51) ux = cpux(512) uy = cpuy(1012) call plchhq(ux,uy,title(1:51),0.015,0.,0.) c --- label ordinate according to escale ux = cpux(20) uy = cpuy(512) if(escale.eq.1) then call plchhq(ux,uy,'E(k)/Var',0.025,90.,0.) elseif(escale.eq.2) then call plchhq(ux,uy,'kE(k)/Var',0.025,90.,0.) elseif(escale.eq.3) then call plchhq(ux,uy,'E(k)/w?B1?*?S1?2',0.025,90.,0.) ccc call plchhq(ux,uy,'E(k)/w:B1:*:S1:2',0.025,90.,0.) ccc call plchhq(ux,uy,'kE(k)/w:B1:*:S1:2',0.025,90.,0.) elseif(escale.eq.4) then call plchhq(ux,uy,'E(k)/w?B1?*?S1?2',0.025,90.,0.) ccc call plchhq(ux,uy,'E(k)/w:B1:*:S1:2',0.025,90.,0.) ccc call plchhq(ux,uy,'kE(k)/t:B1:*:S1:2',0.025,90.,0.) else call plchhq(ux,uy,'E(k)',0.025,90.,0.) endif c --- label abscissa according to kscale ux = cpux(512) uy = cpuy(80) if(kscale.eq.1) then call plchhq(ux,uy,'kL',0.025,0.,0.) elseif(kscale.eq.2) then call plchhq(ux,uy,'kz?B?i',0.025,0.,0.) ccc call plchhq(ux,uy,'kz:B:i',0.025,0.,0.) else if(krad.eq.1) then call plchhq(ux,uy,'k(rad/m)',0.025,0.,0.) else call plchhq(ux,uy,'k(cy/m)',0.025,0.,0.) endif endif call gaseti('LTY',1) if((exfmt.eq.1).and.(eyfmt.eq.0)) then call labmod('(1PE7.1)','(f6.4)',7,6,15,15,0,0,0) elseif((eyfmt.eq.1).and.(exfmt.eq.0)) then call labmod('(f7.2)','(1PE7.1)',6,7,15,15,0,0,0) elseif((exfmt.eq.0).and.(eyfmt.eq.0)) then call labmod('(f7.2)','(f6.4)',6,6,15,15,0,0,0) else call labmod('(1PE7.1)','(1PE7.1)',7,7,15,15,0,0,0) endif c --- specify major and minor tick marks on x,y respectively call periml(mjrx,mnrx,mjry,mnry) c --- specify solid ($) line of length 10 and width 12 units call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) c --- plot the points call curved(xp,yp,np) #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.3) then print 701 701 format(2x,'w spec. yp(j)=e(s)/wstr**2') print 770, (yp(j),j=1,np) c print 702 c 702 format(2x,' abscissa xp(j) = (kx(s)/xlen)*zi ') c print 770, (xp(j),j=1,np) endif c if(iflg.eq.4) then c print 703 c 703 format(2x,'th spec. yp(j)=e(s)/tstr**2') c print 770, (yp(j),j=1,np) c print 702 c print 770, (xp(j),j=1,np) c endif endif C --- plot +/- one sigma lines as dashed if(plotsd.eq.1) then do 75 s=s1,s2 sx = 0. c --- compute average of data plotted do 73 j=1,jymax if(escale.eq.1) then ex = ej(j,s)/varxy elseif(escale.eq.2) then ex = ej(j,s)*kx(s)/varxy elseif(escale.eq.3) then ex = ej(j,s)/(wstr**2) elseif(escale.eq.4) then ex = ej(j,s)/(tstr**2) else ex = ej(j,s) endif ej(j,s) = ex sx = sx + ex 73 continue esum(s) = sx/float(jymax) c --- compute standard deviation (sig) and standard deviation c --- of mean (sdom) for data plotted sigx = 0. do 74 j=1,jymax sigx = sigx + (ej(j,s)-esum(s))**2 74 continue sig(s) = sqrt(sigx/float(jymax-1)) sdom(s) = sig(s)/sqrt(float(jymax)) if(iprint.ge.1) then print *,'s,esum(s)=',s,esum(s) print *,'s,sig(s),sdom(s)=',s,sig(s),sdom(s) endif 75 continue c --- plot +- sdom i=0 do 76 s=s1,s2 i=i+1 yyp(i) = esum(s) + sdom(s) yyp(i) = amax1(yyp(i),UB) yyp(i) = amin1(yyp(i),UT) 76 continue #if (GKS == 1) call dashdc('$''$''$''$''$''$''',10,12) call curved(xp,yyp,np) #endif i=0 do 77 s=s1,s2 i=i+1 yyp(i) = esum(s) - sdom(s) yyp(i) = amax1(yyp(i),UB) yyp(i) = amin1(yyp(i),UT) 77 continue #if (GKS == 1) call curved(xp,yyp,np) #endif c endif c c --- plot the reference line for log-log plots if((plotrf.eq.1) .and. (LL.eq.4)) then xlmax = alog10(0.6*UR) ylmin = jmin + float(ndec)/2. xlmin = imax - float(ndec)/4. ylmax = ylmin - slope*(xlmax-xlmin) ymax = 10.**ylmax if(ymax.gt.UT) then ymax = 0.6*UT ylmax = alog10(ymax) xlmin = xlmax + (ylmax-ylmin)/slope endif xmin = 10.**xlmin xmax = 10.**xlmax ymin = 10.**ylmin ns = 2 xs(1) = xmin ys(1) = ymax xs(2) = xmax ys(2) = ymin #if (GKS == 1) c --- specify solid ($) line of length 10 and width 8 units call dashdc('$$$$$$$$$$$$$$$$$$$$',10,8) c --- plot the points call curved(xs,ys,ns) c --- label it ux = 1.05*xmin uy = ymax if(islope.eq.2) then call plchhq(ux,uy,'-3',0.015,0.,-1.) else call plchhq(ux,uy,'-5/3',0.015,0.,-1.) endif #endif c if(iprint.ge.1) then print *,'slope,xmin,ymin,xmax,ymax=',slope,xmin,ymin,xmax, 1 ymax c --- compute slope of least squares linear fit to data i=0 sx=0. sy=0. st2=0. afit=0. do 81 s=np/2,np i=i+1 xp(i) = alog10(xp(i)) yp(i) = alog10(yp(i)) sx=sx+xp(i) sy=sy+yp(i) 81 continue np = i ss=float(np) sxoss=sx/ss bfit=0. do 82 i=1,np t=xp(i)-sxoss st2=st2+t*t bfit=bfit+t*yp(i) 82 continue bfit=bfit/st2 afit=(sy-sx*bfit)/ss print *,'for last n points: np,afit,bfit =',np,afit,bfit endif !iprint.eq.1 endif !LL.eq.4 c #if (GKS == 1) c --- advance the frame call frame #endif c else c c --- compute and plot the 2D spectrum nns(1) = ndim nns(2) = jymax ntot = nns(1)*nns(2) nwork = nmax*nmax n1d2 = nns(1)/2 n1d2p1 = n1d2+1 n2d2 = nns(2)/2 n2d2p1 = n2d2+1 NTOT = N1D2*N2D2 if(plot0.eq.0) then s1=2 else s1=1 endif if(plotny.eq.0) then s2x=n1d2p1-1 s2y=n2d2p1-1 else s2x=n1d2p1 s2y=n2d2p1 endif c c --- set up coordinate axes for x and y wavenumbers i=0 xmax = -1.0e30 do 97 s=s1,s2x kx(s) = float(s-1) i=i+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen xp(i) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi xp(i) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m xp(i) = kx(s)/xlen endif if((LL.eq.3) .or. (LL.eq.4)) then xp(i) = alog10(amax1(xp(i),1.0e-30)) endif xmax = amax1(xmax,xp(i)) 97 continue nx = i j=0 ymax = -1.0e30 do 98 s=s1,s2y kx(s) = float(s-1) j=j+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen yp(j) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi yp(j) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m yp(j) = kx(s)/xlen endif if((LL.eq.3) .or. (LL.eq.4)) then yp(j) = alog10(amax1(yp(j),1.0e-30)) endif ymax = amax1(ymax,yp(j)) 98 continue ny = j ymax = amax1(ymax,xmax) if(iprint.ge.1) then print *,'computing 2D spectra: nx,ny,s1,s2x,s2y,ymax =', 1 nx,ny,s1,s2x,s2y,ymax print *,'xp=',xp print *,'yp=',yp endif c c --- call the 2D spectral decomposition program to get the c --- Fourier amplitudes ISIGN = +1 IFORM = 0 ii=0 do 92 j=1,nns(2) do 91 i=1,nns(1) ii=ii+1 data1(ii) = fxy(i,j) 91 continue 92 continue CALL FOURT (data1,nn,numdim,ISIGN,IFORM,WORK,nwork,ierr) if(iprint.ge.1) then print *,'FOURT results: nn,numdim,isign,iform,ierr =', 1 nns(1),nns(2),numdim,isign,iform,ierr endif c c --- set up array of spectral amplitudes for use with SRFACE emax = -1.0e30 emin = 1.0e30 if(ierr.eq.0) then kk = 0 do 94 j=1,n2d2p1 do 93 i=1,n1d2p1 kk = kk+1 dkk = data1(kk)/ntot kk = kk+1 dkk1 = data1(kk)/ntot if((i.ge.s1).and.(j.ge.s1) .and. 1 (i.le.s2x).and.(j.le.s2y)) then ii=i-s1+1 jj=j-s1+1 ex = dkk**2 + dkk1**2 if(escale.eq.1) then ex = ex/varxy elseif(escale.eq.2) then ex = ex*kx(s)/varxy elseif(escale.eq.3) then ex = ex/(wstr**2) elseif(escale.eq.4) then ex = ex/(tstr**2) endif ej(ii,jj) = ex emax = amax1(ej(ii,jj),emax) emin = amin1(ej(ii,jj),emin) if(iprint.ge.2) then write(6,114) j,i,kk,jj,ii,dkk,dkk1,ej(ii,jj) endif !iprint.ge.2 endif 93 continue 94 continue c c --- rescale if log option was requested if((LL.eq.2) .or. (LL.eq.4)) then emax = -1.0e30 ylmin = alog10(amax1(emin,1.0e-30)) do 87 jj=1,ny do 86 ii=1,nx ej(ii,jj) = alog10(amax1(ej(ii,jj),1.0e-30)) - ylmin emax = amax1(ej(ii,jj),emax) 86 continue 87 continue endif c c --- SRFACE requires magnitude of e consistent with axis c --- scalings sy = 0.5*ymax/emax do 89 jj=1,ny do 88 ii=1,nx ej(ii,jj)=ej(ii,jj)*sy 88 continue 89 continue #if (GKS == 1) c --- plot it eye(1) = -xp(nx) eye(2) = -yp(ny) eye(3) = 1.5*amax1(abs(eye(1)),abs(eye(2))) eye(4) = 0. eye(5) = 0. eye(6) = 0. stereo = 0.0 call gselnt(0) C --- Set SRFACE parameters to supress FRAME call and draw skirt. IFR = 0 ISKIRT = 1 HSKIRT = 0. call srface(xp, yp, ej, work, nmax, nx, ny, eye, stereo) isize = 35 xx = (xp(nx)-xp(1))/2. yy = yp(1) - .05*(yp(ny)-yp(1)) zz = 0. if((LL.eq.3) .or. (LL.eq.4)) then call pwrzs(xx,yy,zz,'LOG(K) -',8,isize,+1,+2,0) else call pwrzs(xx,yy,zz,'K -',3,isize,+1,+2,0) endif xx = xp(1) - .05*(xp(nx)-xp(1)) yy = (yp(ny)-yp(1))/2. if((LL.eq.3) .or. (LL.eq.4)) then call pwrzs(xx,yy,zz,'- LOG(L)',8,isize,-2,+1,0) else call pwrzs(xx,yy,zz,'- L',3,isize,-2,+1,0) endif c --- attach a title zkm = float(k-1)*dz/1000. if(iflg.eq.1) write (title,105) time,zkm if(iflg.eq.2) write (title,106) time,zkm if(iflg.eq.3) write (title,107) time,zkm if(iflg.eq.4) write (title,108) time,zkm ux = cpux(512) uy = cpuy(1012) call pwrit(ux,uy,title(1:51),51,2,0,0) c --- now advance to the next frame call frame #endif c c --- process error conditions from FOURT elseif(ierr.eq.-1) then write(6,130) iform, (nns(i),i=1,numdim) elseif(ierr.eq.-2) then write(6,170) nwork else write(6,180) ierr endif c endif !1D or 2D c 101 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 102 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 103 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 104 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 105 format(' 2d uprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 106 format(' 2d vprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 107 format(' 2d wprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 108 format('2d thprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 110 format(1h ,'Error in spxypl: all points underground for level =', 1 i4) 112 format(1h ,2i3,1p,2e12.4) 113 format(1H ,'i,fx,Re(C),Im(C) =',I3,1P,3E14.6) 114 format(1h ,5i5,1p,4e12.4) 115 format(1H ,'s,a(s),b(s),E(s) =',I3,1P,3E14.6) 116 format(1H ,'s,esum(s) =',I3,1P,3E14.6) 118 format(1h ,'s,k(s),e(s) =',i3,1p,2e14.6) 119 format(1h ,'j,x(j),y(j) =',i4,1p,2e14.6) 120 format(1h ,'input variance too small for field =',i4,/, 1 ' variance =',e14.6,' number of input points =',i5) 130 FORMAT(1H ,'ERROR IN FOURT. N(1) =',I4,' IS NOT EVEN.') 170 FORMAT(1H ,'ERROR IN FOURT. NWORK =',I4,' IS TOO SMALL') 180 FORMAT(1H ,'ERROR IN FOURT. UNRECOGNIZED ERROR CODE =',I4) 222 format(1h ,1p,5e15.6) c return end subroutine scale1(xmin, xmax, n, xminp, xmaxp, dist,ierr) c given xmin, xmax and n, scale1 finds a new range xminp and c xmaxp divisible into approximately n linear intervals of c size dist. on return ierr=-1 if improper inputs, otherwise c ierr is set to 0. c vint is an array of acceptable values for dist (times an c integer power of 10). c sqr is an array of geometric means of adjacent values of c vint. it is used as break points to determine which vint c value to assign to dist. del accounts for computer c roundoff. it should be greater than the roundoff expected c from a division and float operation, and less than the c minimum increment of the plotting device dived by the c plot size times the number of intervals n. c ref: algorithm 462 from collected algorithms of the CACM implicit none real xmin, xmax, xminp, xmaxp, dist integer n, ierr real a, al, b, del, fm1, fm2, fn integer nal, i, m1, m2 real vint(4), sqr(3) data vint/1., 2., 5., 10./ data sqr/1.414214, 3.162278, 7.071068/ data del/0.00002/ c c check whether proper input values were supplied if((xmin.ge.xmax).or.(n.le.0)) then ierr=-1 return endif c c find approximate interval size a ierr = 0 fn = n a = (xmax-xmin)/fn al = alog10(a) nal = al if(a.lt.1.) nal = nal-1 c scale a into variable b between 1 and 10 b = a/(10.**nal) c find the closest permissible value for b do 20 i=1,3 if(b.lt.sqr(i)) go to 30 20 continue i=4 c compute the interval size 30 dist = vint(i)*10.**nal fm1 = xmin/dist m1 = fm1 if(fm1.lt.0.) m1=m1-1 if(abs(float(m1)+1.-fm1).lt.del) m1 = m1 + 1 c find the new minimum and maximum limits xminp = dist*float(m1) fm2 = xmax/dist m2 = fm2+1. if(fm2.lt.(-1.)) m2=m2-1 if(abs(fm2+1.-float(m2)).lt.del) m2 = m2 - 1 xmaxp = dist*float(m2) c adjust limits to account for roundoff if necessary if(xminp.gt.xmin) xminp = xmin if(xmaxp.lt.xmax) xmaxp = xmax c return end #endif C PLOTPL #endif #if (ENERGY == 1) subroutine sort(arr) include 'param.nml' include 'msg.inc' dimension arr(1-ih:np+ih,1-ih:mp+ih,l) dimension sor(np*mp*l) ik=1 do k=2,l-1 do j=1,mp do i=1,np c sor(ik)=arr(i,j,k) c vertical filter density field before sorting sor(ik)=0.25*(arr(i,j,k+1)+2.*arr(i,j,k)+arr(i,j,k-1)) ik=ik+1 enddo enddo enddo c filter do j=1,mp do i=1,np sor(ik)=arr(i,j,1) ik=ik+1 sor(ik)=arr(i,j,l) ik=ik+1 enddo enddo nml=np*mp*l do ik=1,nml do ii=ik,nml if ( sor(ii) .lt. sor(ik) ) then temp=sor(ii) sor(ii)=sor(ik) sor(ik)=temp endif enddo enddo c largest values at the bottom ik=1 nml=np*mp*l do k=1,l do j=1,mp do i=1,np arr(i,j,k)=sor(nml-ik+1) ik=ik+1 enddo enddo enddo return end subroutine energy(u,v,w,oz,th,p,ehise,ivis,ikf) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension ehise(nth,17) dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l), dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension chm(1-ih:nchp+ih, 1-ih:mchp+ih, lds, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lds, nspc) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension pfx(1-ih:np+ih, 1-ih:mp+ih, l), . pfy(1-ih:np+ih, 1-ih:mp+ih, l), . pfz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l) dimension ekbot(1-ih:np+ih, 1-ih:mp+ih), . epbot(1-ih:np+ih, 1-ih:mp+ih), . pnx(1-ih:np+ih, 1-ih:mp+ih), . pny(1-ih:np+ih, 1-ih:mp+ih), . pnz(1-ih:np+ih, 1-ih:mp+ih) dimension sorarr(1-ih:np+ih, 1-ih:mp+ih,l) common/davies/ relx(np,mp),rely(np,mp),zab,towx,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxab,dyab,iab,iabth,iabqw common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/ttbar/wb(1-ih:np+ih,1-ih:mp+ih,l), . ub(1-ih:np+ih,1-ih:mp+ih,l), . vb(1-ih:np+ih,1-ih:mp+ih,l), . rhob(1-ih:np+ih,1-ih:mp+ih,l), . reyb(1-ih:np+ih,1-ih:mp+ih,l), . ureyb(1-ih:np+ih,1-ih:mp+ih,l), . wstb(1-ih:np+ih,1-ih:mp+ih,l,4), . rstb(1-ih:np+ih,1-ih:mp+ih,l,4), . ustb(1-ih:np+ih,1-ih:mp+ih,l,4), . vstb(1-ih:np+ih,1-ih:mp+ih,l,4), . istore fsi(zt)=zt c assuming boussinesq !!!! lipps==0 do ii=1,17 ehise(ikf,ii)=0. enddo c kin energy do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo do j=1,mp do i=1,np ekbot(i,j)=pfx(i,j,1)/(dx*dy*dz) enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,1),1) c print *,'kin energy ',ikf,ehise(ikf,1) c pfx(:,:,:)=2.5 c pfz(:,:,:)=1. c rho(:,:,:)=1. c call sumcns(pfx,pfy,rho,ehise(ikf,1),1) c print *,'test kin energy ',ikf,ehise(ikf,1) c total potential energy - environmental do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. c pfz(i,j,k)=(1./gi(i,j))*(th(i,j,k)+the(i,j,k)) pfz(i,j,k)=(1./gi(i,j))*th(i,j,k) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,2),1) c available potential energy (pot energy - minimum actual background pot. energy) do k=1,l do j=1,mp do i=1,np sorarr(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo call sort(sorarr) c available potential energy do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=(1./gi(i,j)) . *(th(i,j,k)+the(i,j,k)-sorarr(i,j,k)) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,3),1) c background do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=(1./gi(i,j)) . *(sorarr(i,j,k)-the(i,j,k)) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,15),1) c calculate normal to surface k=1 c note that gradient is normal to surface kk=1 do j=1,mp do i=1,np cx=(s13(i,j)*gmul(kk)-h13(i,j))*gmus(kk) cy=(s23(i,j)*gmul(kk)-h23(i,j))*gmus(kk) cz=gmus(kk)*gi(i,j) zsx=-cx/cz zsy=-cy/cz gnr=sqrt(1.+zsx**2+zsy**2) pnx(i,j)=-zsx/gnr pny(i,j)=-zsy/gnr pnz(i,j)=-1./gnr enddo enddo c total rate of inviscid kinetic energy change == flux at bottom c calculate energy flux at the bottom only, top is assumed flat ehise(ikf,4)=0. do j=1,mp do i=1,np pp=p(i,j,1)*2.*dti ehise(ikf,4)=ehise(ikf,4) . -(rho(i,j,1)*gi(i,j)*ekbot(i,j)+pp) . *(u(i,j,1)*pnx(i,j)+v(i,j,1)*pny(i,j) . +w(i,j,1)*pnz(i,j))*dx*dy enddo enddo c save this, represents external energy flux ?! ehise(ikf,11)=ehise(ikf,4) c total rate of inviscid potential energy change == flux at bottom c calculate energy flux at the bottom only, top is assumed flat ehise(ikf,7)=0. do j=1,mp do i=1,np ehise(ikf,7)=ehise(ikf,7) c . -g*zs(i,j)*(th(i,j,1)+the(i,j,1)) . -g*zs(i,j)*th(i,j,1) . *(u(i,j,1)*pnx(i,j)+v(i,j,1)*pny(i,j) . +w(i,j,1)*pnz(i,j))*dx*dy enddo enddo c save this, represents external energy flux, added ehise(ikf,11)=ehise(ikf,11)+ehise(ikf,7) c calculate absorber towi=1./towz do k=1,l zstr=fsi((k-1)*dz) do j=1,mp do i=1,np zl=zstr/gi(i,j)+zs(i,j) t1=iab*amax1(0.,zl-zab) tau(k,i,j,1)=towi*t1/(zb-zab) c tau(k,i,j,1)=iab*towi*exp((zl-zb)/6.e3) end do end do end do c calculate energy dissipation due to absorber do k=1,l do j=1,mp do i=1,np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =tau(k,i,j,1)*(1.-relt)+relt relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) pfx(i,j,k)=-astr*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,5),1) c print *,'dissip energ',ikf,ehise(ikf,5) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)+ehise(ikf,5) c reversible rate of exchange with pot. energy due to boyancy flux do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*w(i,j,k)*dx*dy*dz pfy(i,j,k)=0. c pfz(i,j,k)=(1./gi(i,j))*(th(i,j,k)+the(i,j,k)) pfz(i,j,k)=(1./gi(i,j))*th(i,j,k) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,6),1) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)-ehise(ikf,6) c update total rate of potential energy change ehise(ikf,7)=ehise(ikf,7)+ehise(ikf,6) c irreversible mean kin. energy growth from pot. energy C_{\bar{K}P} iav=4 avi=1./4. if( ikf.eq.1 ) then istore=1 wb(:,:,:)=0.0 ub(:,:,:)=0.0 vb(:,:,:)=0.0 rhob(:,:,:)=0.0 reyb(:,:,:)=0.0 ureyb(:,:,:)=0.0 endif do k=1,l do j=1,mp do i=1,np wb(i,j,k)=wb(i,j,k)+avi*w(i,j,k) ub(i,j,k)=ub(i,j,k)+avi*u(i,j,k) vb(i,j,k)=vb(i,j,k)+avi*v(i,j,k)*j3 c rhob(i,j,k)=rhob(i,j,k)+avi*(th(i,j,k)+the(i,j,k)) rhob(i,j,k)=rhob(i,j,k)+avi*th(i,j,k) wstb(i,j,k,istore)=w(i,j,k) c rstb(i,j,k,istore)=(th(i,j,k)+the(i,j,k)) rstb(i,j,k,istore)=th(i,j,k) ustb(i,j,k,istore)=u(i,j,k) vstb(i,j,k,istore)=v(i,j,k)*j3 enddo enddo enddo if(ikf/iav*iav.eq.ikf) then do is=1,istore do k=1,l do j=1,mp do i=1,np wprime=wstb(i,j,k,is)-wb(i,j,k) rprime=rstb(i,j,k,is)-rhob(i,j,k) reyb(i,j,k)=reyb(i,j,k)+avi*wprime*rprime enddo enddo enddo enddo c mean kin. energy growth from pot. energy C_{\bar{K}P} do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*wb(i,j,k)*rhob(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,13),1) c mean kin. energy do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(ub(i,j,k)**2+vb(i,j,k)**2+wb(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,16),1) c transient kin energy do is=1,istore do k=1,l do j=1,mp do i=1,np wprime=wstb(i,j,k,is)-wb(i,j,k) uprime=ustb(i,j,k,is)-ub(i,j,k) vprime=vstb(i,j,k,is)-vb(i,j,k) ureyb(i,j,k)=ureyb(i,j,k) . +avi*(uprime**2+vprime**2+wprime**2) enddo enddo enddo enddo do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*ureyb(i,j,k)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,17),1) c transient kin. energy growth from pot. energy C_{\prime{K}P} do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*reyb(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,14),1) do ik=1,3 ehise(ikf-ik,13)=ehise(ikf,13) ehise(ikf-ik,14)=ehise(ikf,14) ehise(ikf-ik,16)=ehise(ikf,16) ehise(ikf-ik,17)=ehise(ikf,17) enddo istore=1 wb(:,:,:)=0.0 ub(:,:,:)=0.0 vb(:,:,:)=0.0 rhob(:,:,:)=0.0 reyb(:,:,:)=0.0 ureyb(:,:,:)=0.0 else istore=istore+1 endif c kinetic energy dissipation due to kinematic viscosity fu,fv,fw c density dissipation due to dissipation of salt/heat #if( SGS == 1 || SGS == 2) if( ivis.eq.1 ) then do k=1,l do j=1,mp do i=1,np ft(i,j,k)=0. fu(i,j,k)=0. fv(i,j,k)=0. fw(i,j,k)=0. enddo enddo enddo #if (SGS == 1) call dissip(u,v,w, 1 th, chm, qv, qc, qr, tke, 1 fx,fy,fz,ft, fchm, qia,qib,fqia,fqib, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 fu, fv, fw, 3 ox,oy,oz) #endif #if (SGS == 2) call dissip(ox1,oy1,oz1, u,v,w, 1 th, qv, qc, qr, tke, c 1 fx,fy,fz,ft, qia,qib,fqia,fqib, 1 fx,fy,fz,ft, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 fu, fv, fw, 3 ox,oy,oz) #endif do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=(u(i,j,k)*fu(i,j,k)+v(i,j,k)*fv(i,j,k) . +w(i,j,k)*fw(i,j,k))*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) c kappa*lapl(th+the) ft(i,j,k)=ft(i,j,k)/2. enddo enddo enddo c total change due to kinematic dissipation (incl. flux + epsilon) c if we want the flux and epsilon contributions separately c dissip needs changing !!! call sumcns(pfx,pfy,pfz,ehise(ikf,8),1) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)+ehise(ikf,8) c update total rate of potential energy change (due to diffusion) do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*ft(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,9),1) ehise(ikf,7)=ehise(ikf,7)+ehise(ikf,9) endif c SGS #endif c external energy flux ehise(ikf,11) c total rate of kinetic energy change ehise(ikf,4) c total rate of potential energy change ehise(ikf,7) c total energy ehise(ikf,10) = ehise(ikf,1) + ehise(ikf,2) c total rate of change (excluding numerical viscosity !!) ehise(ikf,12) = ehise(ikf,4) + ehise(ikf,7) return end C ENERGY #endif #if (TURBPL == 1) subroutine turban(u,v,w,th,p,qv,qc,qr,lipps,e,ivis) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . e(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) dimension awp(l),awn(l) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/gora/ xml,yml,amp,xml0,yml0,angle common/plotur/ iuvpl,ivvpl,iwvpl,ithpl,iprpl, . iqvpl,iqcpl,ikepl,itkpl,idspl, . ihfpl,imfpl,iw3pl,ipwpl,iball common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri data itblpri/0/ data iuvpl/1/,ivvpl/1/,iwvpl/1/,ithpl/1/,iprpl/1/, 1 iqvpl/1/,iqcpl/1/,ikepl/1/,itkpl/1/, 1 ihfpl/1/,imfpl/1/,iw3pl/1/,iskew/1/,ipwpl/1/, 1 iarea/1/,iball/1/ c inorm=1 if(hf00.eq.0.) then inorm=0 iball=0 endif nml=n*m*l nm=n*m ivvpl=ivvpl*j3 iqvpl=iqvpl*moist iqcpl=iqcpl*moist itkpl=itkpl*ivis if(j3.eq.1) then !3D case cii=2./3. else !2D case cii=2./2. endif convert sqrt(tke) to tke if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l e(i,j,k)=e(i,j,k)**2 enddo enddo enddo endif covariance statistics if(inorm.eq.1.or.ihfpl.eq.1) then call reystress(th,w,n,m,l, 3,lipps) call reystress(th,u,n,m,l,31,lipps) call reystress(th,v,n,m,l,32,lipps) endif if(imfpl.eq.1) then call reystress(u,w,n,m,l,1,lipps) call reystress(v,w,n,m,l,2,lipps) endif if(ipwpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) enddo enddo enddo endif call reystress(f1,w,n,m,l, 4,lipps) call reystress(f1,u,n,m,l,41,lipps) call reystress(f1,v,n,m,l,42,lipps) endif if(iw3pl.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l, 8,lipps) call reystress( u,w,n,m,l,81,lipps) call reystress( v,w,n,m,l,82,lipps) endif if(iskew.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l, 9,lipps) do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l,91,lipps) endif if (iuvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=u(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=u(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,1) endif if (ivvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=v(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=v(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,2) endif if (iwvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,3) endif if (ithpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,4) endif if (iprpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) f2(i,j,1)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,5) endif if (iqvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=qv(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=qv(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,6) endif if (iqcpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=qc(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=qc(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,7) endif if (ikepl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2) f2(i,j,k)=e(i,j,k) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,8) endif if(iarea.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=1. if(w(i,j,k).le.0.) f1(i,j,k)=0. f2(i,j,k)=1.-f1(i,j,k) enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,0) do i=1,n do j=1,m do k=1,l f1(i,j,k)=amax1(0.,w(i,j,k)) f2(i,j,k)=amin1(0.,w(i,j,k)) enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,1) call aver(th,zcr,n,m,l) do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k)-the(i,j,k)*0.-zcr(k)*1. f2(i,j,k)=th(i,j,k)-the(i,j,k)*0.-zcr(k)*1. if(w(i,j,k).gt.0.) then f2(i,j,k)=0. else f1(i,j,k)=0. endif enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,2) endif if(iball.eq.1) call budget(u,v,w,p,th,e,lipps,ivis) inorm=0 convert tke back to sqrt(tke) if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l e(i,j,k)=sqrt(e(i,j,k)) enddo enddo enddo endif return end subroutine budget(u,v,w,p,th,e,lipps,ivis) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . e(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) dimension fl(l,6) character*80 lhead #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/sgscnst/ ceps,cL,cm,cs,prndt common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/srprint/ itblpri nml=n*m*l nm=n*m if(j3.eq.1) then !3D case cii=2./3. c deltl=(dx*dy*dz)**(1./3.) deltl=1.*(dx+dy+dz)/3. c deltl=amax1(dx,dy,dz) c deltl=sqrt(0.5*(dx**2+dy**2+dz**2)) else !2D case cii=2./2. deltl=sqrt(dx*dz) endif xnorm=zi/wstr**3 call fluxb(th,w,fl(1,1),n,m,l,1,lipps) do k=1,l zcr(k)=(k-1)*dz enddo call thprof(fl(1,2),zcr,l,lipps) do k=1,l fl(k,1)=g*fl(k,1)/fl(k,2)*xnorm enddo do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call fluxb(f1,w,fl(1,2),n,m,l, 2,lipps) call fluxb( u,w,fl(1,3),n,m,l,21,lipps) call fluxb( v,w,fl(1,4),n,m,l,22,lipps) do k=1,l fl(k,2)=0.5*(fl(k,2)+fl(k,3)+fl(k,4)) enddo if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) enddo enddo enddo endif call fluxb(f1,w,fl(1,3),n,m,l,3,lipps) do k=1,l fl(k,2)=fl(k,2)+fl(k,3) enddo do k=2,l-1 fl(k,3)=(fl(k+1,2)-fl(k-1,2))*dzi*0.5 enddo fl(1,3)=(fl(2,2)-fl(1 ,2))*dzi fl(l,3)=(fl(l,2)-fl(l-1,2))*dzi do k=1,l fl(k,2)=-fl(k,3)*xnorm enddo c filter c do k=2,l-1 c fl(k,3)=0.25*(fl(k+1,2)+2.*fl(k,2)+fl(k-1,2)) c enddo c do k=2,l-1 c fl(k,2)=fl(k,3) c enddo if(ivis.eq.1) then eps=1.e-15 do i=1,n do j=1,m do k=1,l EsqE=e(i,j,k)*sqrt(e(i,j,k)) cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) c cLz=cL*amax1((k-1)*dz/gi(i,j),zo(i,j)) Diss=ceps*EsqE/( (1-ibcz)*amin1(cLz,deltl) . +ibcz*deltl ) f1(i,j,k)=Diss enddo enddo enddo do i=1,n do j=1,m f1(i,j,1)=0. enddo enddo call aver(f1,fl(1,3),n,m,l) else do k=1,l fl(k,3)=0. enddo endif do k=1,l fl(k,3)=-fl(k,3)*xnorm enddo call aver( u,fl(1,4),n,m,l) do k=2,l-1 fl(k,5)=(fl(k+1,4)-fl(k-1,4))*dzi*0.5 enddo fl(1,5)=(fl(2,4)-fl(1 ,4))*dzi fl(l,5)=(fl(l,4)-fl(l-1,4))*dzi call fluxb(u,w,fl(1,4),n,m,l,4,lipps) do k=1,l fl(k,4)=-fl(k,4)*fl(k,5)*xnorm enddo call aver( v,fl(1,5),n,m,l) do k=2,l-1 fl(k,6)=(fl(k+1,5)-fl(k-1,5))*dzi*0.5 enddo fl(1,6)=(fl(2,5)-fl(1 ,5))*dzi fl(l,6)=(fl(l,5)-fl(l-1,5))*dzi call fluxb(v,w,fl(1,5),n,m,l,5,lipps) do k=1,l fl(k,5)=-fl(k,5)*fl(k,6)*xnorm enddo do k=1,l fl(k,6)=fl(k,1)+fl(k,2)+fl(k,3)+fl(k,4)+fl(k,5) enddo zlam=1.e-2 ntp=l top=(ntp-1)*dz/zlam do 1 kc=1,l 1 zcr(kc)=(kc-1)*dz if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 do 22 k=1,l zcr(k)=zcr(k)/zlam t1=amax1(t1,fl(k,1),fl(k,2),fl(k,3),fl(k,4),fl(k,5),fl(k,6)) 22 t2=amin1(t2,fl(k,1),fl(k,2),fl(k,3),fl(k,4),fl(k,5),fl(k,6)) c ... set limits del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) write (lhead,100) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call set(.1,.9,.1,.9,0.,1.,0.,top,1) call gaseti('LTY',1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.9,.1,.9,slim1,slim2,0.,top,1) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fl(1,1),zcr,l) call dashdc('$$''$$''$$''$$''$$''',10,12) call curved(fl(1,2),zcr,l) call dashdc('$$$''$$$''$$$''$$$''',10,12) call curved(fl(1,3),zcr,l) call dashdc('$$$$''$$$$''$$$$''',10,12) call curved(fl(1,4),zcr,l) call dashdc('$$$$$''$$$$$''$$$$$''',10,12) call curved(fl(1,5),zcr,l) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fl(1,6),zcr,l) call frame #endif if(itblpri.eq.1) then 769 format(24x,' next ') 770 format(4x,e14.7) print 701 701 format(2x,' *** elements of tke budget *** ') print 770, (fl(k,1),k=1,l) print 769 print 770, (fl(k,2),k=1,l) print 769 print 770, (fl(k,3),k=1,l) print 769 print 770, (fl(k,4),k=1,l) print 769 print 770, (fl(k,5),k=1,l) print 769 print 770, (fl(k,6),k=1,l) endif 100 format('tke budget at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine fluxb(f,w,reys,n1,n2,n3,iflg,lipps) include 'param.nml' include 'msg.inc' real reys(n3) character*80 lhead dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(l),wav(l),zcr(l),wgt(l),ar(l),rho(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm #if (ANALIZE == 0) common/blank/ ri3(1-ih:np+ih, 1-ih:mp+ih, l, 3), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri3(1-ih:np+ih, 1-ih:mp+ih, l, 3), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 4) #endif nsq=1 if(iflg.eq.2.or.iflg.eq.21.or.iflg.eq.22) nsq=2 il=1 ir=n1-ibcx jl=1 jr=n2-ibcy do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz call density profile call rhprof(rho,zcr,n3,lipps) create interpolated fields call interz( f, fz, fav,wgt,n1,n2,n3) call interz( w, wz, wav,wgt,n1,n2,n3) compute fluxes cnorm=1. ip=0 do 3 kc=n3,1,-1 reys(kc)=0. do i=il,ir do j=jl,jr reys(kc) = reys(kc) + * (fz(i,j,kc)-fav(kc))**nsq*(wz(i,j,kc)-wav(kc))*rho(kc) enddo enddo if (wgt(kc).gt.0.) then reys(kc)=reys(kc)/wgt(kc) ip=ip+1 else reys(kc)=2.*reys(kc+1)-reys(kc+2) endif 3 continue return end subroutine aver(f,fav,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(n3),wgt(l),zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc il=1 ir=n1-ibcx jl=1 jr=n2-ibcy do 1 kc=1,n3 zcr(kc)=(kc-1)*dz 1 continue do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fav(kc)=fav(kc) + f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if (wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue return end subroutine statv(f,e,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . e(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fsd(l),fss(l),wgt(l) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e-2 ntp=n3 top=(ntp-1)*dz/zlam il=1 ir=n1-ibcx jl=1 jr=n2-ibcy nml=n1*n2*n3 do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. fss(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) fss(kc)=fss(kc) + * e(i,j,kbrm)+(e(i,j,kbr)-e(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) fss(kc)=fss(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) fss(kc)=2.*fss(kc+1)-fss(kc+2) endif 2 continue if(iflg.eq.8) then do kc=1,n3 fsd(kc)=fav(kc)+fss(kc) enddo endif if(iflg.ne.8) then compute zonal-mean of primed variables + tke contribution do 3 kc=n3,1,-1 fsd(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fsd(kc)=fsd(kc) + ( f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm)) * *(brk-float(kbrm))-fav(kc) )**2 wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fsd(kc)=fsd(kc)/wgt(kc) else fsd(kc)=2.*fsd(kc+1)-fsd(kc+2) endif 3 continue do kc=1,n3 fsd(kc)=fsd(kc)+fss(kc) enddo endif if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.le.3.or.iflg.eq.8) xnorm=1./wstr**2 if(iflg.eq.4) xnorm=1./tstr**2 if(iflg.eq.5) xnorm=1./wstr**4 if(iflg.eq.6.or.iflg.eq.7) xnorm=1./qstr**2 do k=1,n3 fsd(k)=fsd(k)*xnorm fss(k)=fss(k)*xnorm enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k)) t2=amin1(t2,fav(k)) 22 t3=amax1(t3,fsd(k),fss(k)) c ... set limits on fsd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time if(iflg.eq.3) write (lhead,103) time if(iflg.eq.4) write (lhead,104) time if(iflg.eq.5) write (lhead,105) time if(iflg.eq.6) write (lhead,106) time if(iflg.eq.7) write (lhead,107) time if(iflg.eq.8) write (lhead,108) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call plchhq(cpux(307),cpuy(50),'mean resolved',0.015,0.,0.) if(iflg.eq.8) then call plchhq(cpux(717),cpuy(50),'total and subgrid',0.015,0.,0.) else call plchhq(cpux(717),cpuy(50),'variance, total and subgrid', . 0.015,0.,0.) endif call gaseti('LTY',1) call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fsd,zcr,n3) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fss,zcr,n3) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.1) then print 701 701 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif if(iflg.eq.3) then print 703 703 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif if(iflg.eq.4) then print 7041 7041 format(2x,' *** *** ') print 770, (fav(k),k=1,l) print 7042 7042 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif endif 101 format('u statistics at time= ',f9.2) 102 format('v statistics at time= ',f9.2) 103 format('w statistics at time= ',f9.2) 104 format('theta statistics at time= ',f9.2) 105 format('p/rho statistics at time= ',f9.2) 106 format('qv statistics at time= ',f9.2) 107 format('qc statistics at time= ',f9.2) 108 format('kin. en. statistics at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine areapl(f,e,awp,awn,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . e(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fss(l),wgt(l),awp(n3),awn(n3) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e-2 ntp=n3 top=(ntp-1)*dz/zlam il=1 ir=n1-ibcx jl=1 jr=n2-ibcy nml=n1*n2*n3 do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. fss(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) fss(kc)=fss(kc) + * e(i,j,kbrm)+(e(i,j,kbr)-e(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) fss(kc)=fss(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) fss(kc)=2.*fss(kc+1)-fss(kc+2) endif 2 continue if(iflg.eq.0) then do k=1,n3 awp(k)=fav(k) awn(k)=fss(k) enddo else do k=2,n3-1 fav(k)=fav(k)/awp(k) fss(k)=fss(k)/awn(k) enddo endif if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.eq.0) xnorm=1. if(iflg.eq.1) xnorm=1./wstr if(iflg.eq.2) xnorm=1./tstr do k=1,n3 fav(k)=fav(k)*xnorm fss(k)=fss(k)*xnorm enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k),fss(k)) 22 t2=amin1(t2,fav(k),fss(k)) c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) if(iflg.eq.0) write (lhead,100) time if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call set(.1,.9,.1,.9,0.,1.,0.,top,1) call gaseti('LTY',1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.9,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fss,zcr,n3) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.1) then print 7011 7011 format(2x,' *** w in ups *** ') print 770, (fav(k),k=1,l) print 7012 7012 format(2x,' *** w in downs *** ') print 770, (fss(k),k=1,l) endif if(iflg.eq.2) then print 7031 7031 format(2x,' *** thp in ups *** ') print 770, (fav(k),k=1,l) print 7032 7032 format(2x,' *** thp in downs *** ') print 770, (fss(k),k=1,l) endif endif 100 format('up/down-drafts areas at time= ',f9.2) 101 format('w in ups and downs at time= ',f9.2) 102 format('th in ups and downs at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end C TURBPL #endif subroutine profil(f,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fsd(l),wgt(l) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c c zlam=1.e3 ntp=n3 top=(ntp-1)*dz/zlam if( icylind.eq.1 ) then jl=1 jr=n2-ibcy il=(n1-1)/2 ir=(n1-1)/2 else il=1 ir=n1-ibcx c 3d plotting, only equator jl=(n2-1)/2 jr=(n2-1)/2 c 2d plotting or average over tank c jl=1 c jr=n2-ibcy endif do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue compute zonal-mean of primed variables do 3 kc=n3,1,-1 fsd(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fsd(kc)=fsd(kc) + ( f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm)) * *(brk-float(kbrm))-fav(kc) )**2 wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fsd(kc)=fsd(kc)/wgt(kc) else fsd(kc)=2.*fsd(kc+1)-fsd(kc+2) endif 3 continue if( iflg.eq.16 ) then do i=1,l if( fav(i).gt.0. ) then fav(i)=min(10.,fav(i)) else fav(i)=max(-10.,fav(i)) endif enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k)) t2=amin1(t2,fav(k)) 22 t3=amax1(t3,fsd(k)) c ... set limits on fsd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call sflush call gstxci(1) call gsplci(1) call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) call pcsetc('FC - FUNCTION CODE CHARACTER','?') call wrtitl(lhead,iflg,time,1,0) call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),.015,0.,0.) call plchhq(cpux(990),cpuy(512),'z [km] -->',.02,90.,0.) call plchhq(cpux(307),cpuy(50),'mean',.015,0.,0.) call plchhq(cpux(717),cpuy(50),'st. dev.',.015,0.,0.) call gaseti('LTY',1) call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) call pcsetc('FC - FUNCTION CODE CHARACTER','?') write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) call pcsetc('FC - FUNCTION CODE CHARACTER','?') write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fsd,zcr,n3) call frame #endif 200 format(e11.4,' -->',e11.4) return end #if (VORTPL == 1) subroutine plov(u,v,w,om,th,vrx,vry,vrz) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . om(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . vrx(1-ih:np+ih, 1-ih:mp+ih, l), . vry(1-ih:np+ih, 1-ih:mp+ih, l), . vrz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fxz(n,l),fyz(m,l),fxy(n,m),uxz(n,l), . wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) #if (ANALIZE == 0) common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . vx(1-ih:np+ih, 1-ih:mp+ih, l), . vy(1-ih:np+ih, 1-ih:mp+ih, l), . vz(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . vx(1-ih:np+ih, 1-ih:mp+ih, l), . vy(1-ih:np+ih, 1-ih:mp+ih, l), . vz(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) data isx,isy/0,0/ data ivctpl/0/ data izcr0/0/ c ipvpl calculate and plot Ertel potential vorticity c ithpl plot PV on theta surfaces (compute PV first on zbar surfaces, c compute the height of isentropic surfaces next, and interpolate c PV onto them---do not recommend unless theta surfaces are c relatively flat) c inorm compute normalized PV (divide by a norm of the potential c temperature gradient vector) data inorm/1/ data ivxpl/1/,ivypl/1/,ivzpl/1/,ipvpl/0/,ithpl/0/ data ixzpl/1/,iyzpl/1/,ixypl/1/,iprfl/0/,iflxpl/0/,ixyzpl/0/ create vertical frames common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 c pi = acos(-1.) nml=n*m*l nm=n*m if(j3.eq.0) then ivxpl=0 ivzpl=0 iyzpl=0 ixypl=0 ixyzpl=0 isy=0 endif c if(ipvpl.eq.1) call pvort(th,vrx,vry,vrz,n,m,l,ithpl,inorm) contour level density nclv=13 c c contour plots follow if(iprfl.eq.1) then if(ivxpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vrx(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,71) endif if(ivypl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vry(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,72) endif if(ivzpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vrz(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,73) endif if(ipvpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=pv(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,74) endif endif close profiles if(ixzpl.eq.1) then jc=(1+m)/2 j1=jc jm=jc ji=1 do 777 j=j1,jm,ji do 200 k=1,l do 200 i=1,n uxz(i,k)=0.5*(u(i,j,k)+u(i,j+isy,k)) 200 wxz(i,k)=0.5*(w(i,j,k)+w(i,j+isy,k))*(2-ivctpl) . +0.5*(om(i,j,k)+om(i,j+isy,k))*(ivctpl-1) do 1017 k=1,l do 1017 i=1,n xnor0=sqrt(wxz(i,k)**2+uxz(i,k)**2) wxz(i,k)=wxz(i,k)*dx*dzi*rat1 xnort=sqrt(wxz(i,k)**2+uxz(i,k)**2) xcos=uxz(i,k)/(xnort+1.e-15) xsin=wxz(i,k)/(xnort+1.e-15) uxz(i,k)=xnor0*xcos wxz(i,k)=xnor0*xsin 1017 continue if(ivxpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vrx(i,j,k)+vrx(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,71,nclv) endif if(ivypl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vry(i,j,k)+vry(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,72,nclv) endif if(ivzpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vrz(i,j,k)+vrz(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,73,nclv) endif if(ipvpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(pv(i,j,k)+pv(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,74,nclv) endif 777 continue endif close xzplots if(iyzpl.eq.1) then ic=(1+n)/2 i1=ic-ic/2 in=ic+ic/2 ii=ic/2 do 888 i=i1,in,ii do 300 k=1,l do 300 j=1,m vyz(j,k)=0.5*(v(i,j,k)+v(i+isx,j,k)) 300 wyz(j,k)=0.5*(w(i,j,k)+w(i+isx,j,k))*(2-ivctpl) . +0.5*(om(i,j,k)+om(i+isx,j,k))*(ivctpl-1) do 2017 k=1,l do 2017 j=1,m xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi*rat2 xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xcos=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 2017 wyz(j,k)=xnor0*xsin if(ivxpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vrx(i,j,k)+vrx(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,71,nclv) endif if(ivypl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vry(i,j,k)+vry(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,72,nclv) endif if(ivzpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vrz(i,j,k)+vrz(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,73,nclv) endif if(ipvpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(pv(i,j,k)+pv(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,74,nclv) endif 888 continue endif close yzplots if(ixypl.eq.1) then do 998 izcr=0,izcr0 if(izcr.eq.0) then k1=1 kl=1 kk=1 else k1=11 kl=41 kk=10 endif do 999 k=k1,kl,kk if (ivctpl.eq.1) then call inzxy(k,u,uxy,n,m,l,izcr,0,nkug) call inzxy(k,v,vxy,n,m,l,izcr,0,nkug) do 400 j=1,m do 400 i=1,n xnor0=sqrt(uxy(i,j)**2+vxy(i,j)**2) vxy(i,j)=vxy(i,j)*dx*dyi*rat3 xnort=sqrt(uxy(i,j)**2+vxy(i,j)**2) xcos=uxy(i,j)/(xnort+1.e-15) xsin=vxy(i,j)/(xnort+1.e-15) uxy(i,j)=xnor0*xcos 400 vxy(i,j)=xnor0*xsin endif if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=zth(i,j,k) end do end do call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,77,nclv) end if if (ivxpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vx(i,j,k) end do end do else call inzxy(k,vrx,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,71,nclv) end if if (ivypl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vy(i,j,k) end do end do else call inzxy(k,vry,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,72,nclv) end if if (ivzpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vz(i,j,k) end do end do else call inzxy(k,vrz,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,73,nclv) end if if (ipvpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=pv(i,j,k) end do end do else call inzxy(k,pv,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,74,nclv) end if 999 continue 998 continue close xyplot endif if(ixyzpl.eq.1) then if(ipvpl.eq.1.and.ithpl.eq.1) *call pvort(th,vrx,vry,vrz,n,m,l,0,inorm) do i=1,n do j=1,m do k=1,l c zs3(i,j,1)=0. zs3(i,j,k)=0. if(zs(i,j).gt.1.e-3) zs3(i,j,k)=1. enddo enddo enddo if (ivxpl.eq.1) then call inzxy3(vrx,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,71) end if if (ivypl.eq.1) then call inzxy3(vry,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,72) end if if (ivzpl.eq.1) then call inzxy3(vrz,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,73) end if if (ipvpl.eq.1) then call inzxy3(pv,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,74) end if close xyzplot endif return end subroutine pvort(th,vrx,vry,vrz,n11,n22,n33,ith,inorm) include 'param.nml' include 'msg.inc' parameter (n1=np,n2=mp,n3=l) dimension th(1-ih:np+ih,1-ih:mp+ih,l), . vrx(1-ih:np+ih,1-ih:mp+ih,l), . vry(1-ih:np+ih,1-ih:mp+ih,l), . vrz(1-ih:np+ih,1-ih:mp+ih,l) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . thx(1-ih:np+ih, 1-ih:mp+ih, l), . thy(1-ih:np+ih, 1-ih:mp+ih, l), . thz(1-ih:np+ih, 1-ih:mp+ih, l), . thn(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr9(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . thx(1-ih:np+ih, 1-ih:mp+ih, l), . thy(1-ih:np+ih, 1-ih:mp+ih, l), . thz(1-ih:np+ih, 1-ih:mp+ih, l), . thn(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif call update(th,np,mp,l,np,mp,iup) nml=n*m*l dxil=0.5*dxi dyil=0.5*dyi dzil=0.5*dzi eps=1.e-15 calculate potential temperature gradients everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do k=1,n3 do j=1,n2 do i=illim,iulim thx(i,j,k)=dxil*(th(i+1,j,k)-th(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,n3 do j=1,n2 thx(1,j,k)=(1-ibcx)*dxi*(th(2,j,k)-th(1,j,k)) * +ibcx*dxil*(th(2,j,k)-th(-1,j,k)) enddo enddo end if if (rightedge.eq.1) then do k=1,n3 do j=1,n2 thx(n1,j,k)=(1-ibcx)*dxi*(th(n1,j,k)-th(n1-1,j,k)) * +ibcx*dxil*(th(n1+2,j,k)-th(n1-1,j,k)) enddo enddo end if #endif if (j3 .eq. 1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp - j3*topedge #else jllim = 1 julim = mp #endif do k=1,n3 do j=jllim,julim do i=1,n1 thy(i,j,k)=dyil*(th(i,j+1,k)-th(i,j-1,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then thy(i,1,k)=(1-ibcy)*dyi*(th(i,1+j3,k)-th(i,1,k)) * +ibcy*dyil*(th(i,1+j3,k)-th(i,-j3,k)) end if if (topedge.eq.1) then thy(i,n2,k)=(1-ibcy)*dyi*(th(i,n2,k)-th(i,n2-j3,k)) * +ibcy*dyil*(th(i,n2+2,k)-th(i,n2-j3,k)) end if #endif else do k=1,n3 do j=1,n2 do i=1,n1 thy(i,j,k)=0. enddo enddo enddo end if do i=1,n1 do j=1,n2 do k=2,n3-1 thz(i,j,k)=dzil*(th(i,j,k+1)-th(i,j,k-1)) enddo thz(i,j,1)=dzi*(th(i,j,2)-th(i,j,1)) thz(i,j,l)=dzi*(th(i,j,l)-th(i,j,l-1)) enddo enddo do k=1,n3 do j=1,n2 do i=1,n1 thx(i,j,k)=thx(i,j,k)+c13(i,j)*gmul(k)*thz(i,j,k) thy(i,j,k)=thy(i,j,k)+c23(i,j)*gmul(k)*thz(i,j,k) thz(i,j,k)=gi(i,j)*thz(i,j,k) enddo enddo enddo calculate potential vorticity on zbar-surfaces do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k) = dti*(thx(i,j,k)*vrx(i,j,k) + * thy(i,j,k)*vry(i,j,k) + * thz(i,j,k)*vrz(i,j,k) )/ * (rho(i,j,k)*gi(i,j)) enddo enddo enddo calculate the norm of the potential temperature vector if (inorm.eq.1) then do k=1,n3 do j=1,n2 do i=1,n1 thn(i,j,k) = sqrt( thx(i,j,k)*thx(i,j,k) . +thy(i,j,k)*thy(i,j,k) . +thz(i,j,k)*thz(i,j,k)) * /(rho(i,j,k)*gi(i,j)*dt) enddo enddo enddo calculate normalized potential vorticity on zbar-surfaces do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k) = pv(i,j,k)/(thn(i,j,k)+eps) enddo enddo enddo end if create interpolated vorticity and pv field on isentropic surfaces construct isentropic sufaces first if (ith .eq. 1) then do kth=1,n3 do j=1,n2 do i=1,n1 if (the(1,1,kth) .le. th(i,j,1)) then zth(i,j,kth)=0. else if (the(1,1,kth) .ge. th(i,j,n3)) then zth(i,j,kth)=zb else do k=2,n3 if (the(1,1,kth) .ge. th(i,j,k-1) .and. * the(1,1,kth) .le. th(i,j,k) ) then zth(i,j,kth) = zcr(k) + * (zcr(k)-zcr(k-1))*(the(1,1,kth)-th(i,j,k))/ * (th(i,j,k)-th(i,j,k-1)+eps) if (zth(i,j,kth) .le. 0) then zth(i,j,kth)=0. else zth(i,j,kth)=zs(i,j)+zth(i,j,kth)/gi(i,j) end if end if end do end if end do end do end do do kth=n3,1,-1 do j=1,n2 do i=1,n1 zbr=zth(i,j,kth) if (zbr .gt. 0.) then brk=zbr*dzi+1. kbr=min0(n3,nint(brk+.5)) kbrm=kbr-1 thx(i,j,kth)=vrx(i,j,kbrm)+ * (vrx(i,j,kbr)-vrx(i,j,kbrm))*(brk-float(kbrm)) thy(i,j,kth)=vry(i,j,kbrm)+ * (vry(i,j,kbr)-vry(i,j,kbrm))*(brk-float(kbrm)) thz(i,j,kth)=vrz(i,j,kbrm)+ * (vrz(i,j,kbr)-vrz(i,j,kbrm))*(brk-float(kbrm)) thn(i,j,kth)=pv(i,j,kbrm)+ * (pv(i,j,kbr)-pv(i,j,kbrm))*(brk-float(kbrm)) else thx(i,j,kth)=0. thy(i,j,kth)=0. thz(i,j,kth)=0. thn(i,j,kth)=0. end if enddo enddo enddo do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k)=thn(i,j,k) enddo enddo enddo end if compute some diagnostics for PV pvmx=-1.e15 pvmn= 1.e15 pvav= 0. c do i=1,n c do j=1,m c do k=1,l c pvmx=amax1(pvmx,pv(i,j,k)) c pvmn=amin1(pvmn,pv(i,j,k)) c pvav= pvav+pv(i,j,k) c enddo c enddo c enddo pvmx=globmax(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvmn=globmin(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvav=globsum(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvav=pvav/float(nml) pvsd=0. do i=1,n do j=1,m do k=1,l c pvsd=pvsd+(pv(i,j,k)-pvav)**2 temp(i,j,k)=(pv(i,j,k)-pvav)**2 enddo enddo enddo pvsd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvsd=sqrt(pvsd/float(nml)) if (mype.eq.0) then print 201, pvmx,pvmn,pvav,pvsd 201 format(1x,'pvmx,pvmn,pvav,pvsd:',4e11.4) endif return end subroutine vort(u,v,w,vrx,vry,vrz,iflg) c iflg - flag for vorticity (0) or c perturbation vorticity (1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . vrx(1-ih:np+ih, 1-ih:mp+ih, l), . vry(1-ih:np+ih, 1-ih:mp+ih, l), . vrz(1-ih:np+ih, 1-ih:mp+ih, l), . dzil(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue (1-ih:np+ih,1-ih:mp+ih,l), . ve (1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih), + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (ANALIZE == 0) common/blank/ ug(1-ih:np+ih, 1-ih:mp+ih, l), . vg(1-ih:np+ih, 1-ih:mp+ih, l), . wg(1-ih:np+ih, 1-ih:mp+ih, l), . ugc(1-ih:np+ih, 1-ih:mp+ih, l), . vgc(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 8) #else common/blank/ ug(1-ih:np+ih, 1-ih:mp+ih, l), . vg(1-ih:np+ih, 1-ih:mp+ih, l), . wg(1-ih:np+ih, 1-ih:mp+ih, l), . ugc(1-ih:np+ih, 1-ih:mp+ih, l), . vgc(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l) #endif c-------------------------------------------------------- c ---- define metric weighted velocities * dt do k=1,l do j=1,mp do i=1,np ug(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k)) * dt vg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k)) * dt wg(i,j,k)=w(i,j,k) * dt g110i=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. g220i=gmm(i,j,k) ugc(i,j,k)=ug(i,j,k)*g110i vgc(i,j,k)=vg(i,j,k)*g220i enddo enddo enddo call update(ug,np,mp,l,np,mp,iup) call update(vg,np,mp,l,np,mp,iup) call update(wg,np,mp,l,np,mp,iup) call update(ugc,np,mp,l,np,mp,iup) call update(vgc,np,mp,l,np,mp,iup) c-------------------------------------------------------- c ---- establish special indices and increments do k=1,l dzil(k)=0.5*dzi enddo dzil(1)=ibcz*(0.5*dzi)+(1-ibcz)*dzi dzil(l)=ibcz*(0.5*dzi)+(1-ibcz)*dzi c ---- begin main loop do k=1,l km=ibcz*(k-1+(l+1-k)/l*(l-1))+(1-ibcz)*max0(k-1,1) kp=ibcz*(k+1 -k /l*(l-1))+(1-ibcz)*min0(k+1,l) do j=1,mp #if (POLES == 0) if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + (1-ibcy)*1 dyil=ibcy*(0.5*dyi)+(1-ibcy)*dyi else jm = j - 1 dyil=0.5*dyi end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + (1-ibcy)*mp dyil=ibcy*(0.5*dyi)+(1-ibcy)*dyi else jp = j + 1 dyil=0.5*dyi end if #else jm = j - 1 jp = j + 1 dyil=0.5*dyi #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + (1-ibcx)*1 dxil=ibcx*(0.5*dxi)+(1-ibcx)*dxi else im = i - 1 dxil=0.5*dxi end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + (1-ibcx)*np dxil=ibcx*(0.5*dxi)+(1-ibcx)*dxi else ip = i + 1 dxil=0.5*dxi end if #else im = i - 1 ip = i + 1 dxil=0.5*dxi #endif c ---- establish metric coefficients g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k)*j3 g11=strxx(i,j) g12=stryx(i,j) g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g21=strxy(i,j) g22=stryy(i,j) g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33=gi(i,j)*gmus(k) c ---- compute the vorticity *dt vrx(i,j,k)=g220*( dxil *g21*(wg(ip,j,k)-wg(im,j,k)) 1 + dyil *g22*(wg(i,jp,k)-wg(i,jm,k)) 2 + dzil(k)*g23*(wg(i,j,kp)-wg(i,j,km)) 3 - dzil(k)*g33*(vgc(i,j,kp)-vgc(i,j,km)) ) vry(i,j,k)=g110* ( dzil(k)*g33*(ugc(i,j,kp)-ugc(i,j,km)) 2 - ( dxil *g11*(wg(ip,j,k)-wg(im,j,k)) 3 + dyil *g12*(wg(i,jp,k)-wg(i,jm,k)) 4 + dzil(k)*g13*(wg(i,j,kp)-wg(i,j,km)) ) ) vrz(i,j,k)=g110*g220*( 1 (dxil *g11*(vgc(ip,j,k)-vgc(im,j,k)) 1 + dyil *g12*(vgc(i,jp,k)-vgc(i,jm,k)) 2 + dzil(k)*g13*(vgc(i,j,kp)-vgc(i,j,km)) ) . - (dxil *g21*(ugc(ip,j,k)-ugc(im,j,k)) 4 + dyil *g22*(ugc(i,jp,k)-ugc(i,jm,k)) 5 + dzil(k)*g23*(ugc(i,j,kp)-ugc(i,j,km)) ) ) enddo enddo enddo ! end main loop c-------------------------------------------------------- C---------> enforce boundary conditions icyclfrc=0 if(icyclfrc.eq.1) then if(ibcz.eq.0) then do j=1,mp do i=1,np vrx(i,j,1)=vrx(i,j, 2 ) vrx(i,j,l)=vrx(i,j,l-1) vry(i,j,1)=vry(i,j, 2 ) vry(i,j,l)=vry(i,j,l-1) vrz(i,j,1)=vrz(i,j, 2 ) vrz(i,j,l)=vrz(i,j,l-1) enddo enddo endif #if (POLES == 0) if(leftedge.eq.1.and.ibcx.eq.0) then do k=1,l do j=1,mp vrx(1,j,k)=vrx(2,j,k) vry(1,j,k)=vry(2,j,k) vrz(1,j,k)=vrz(2,j,k) enddo enddo endif if(rightedge.eq.1.and.ibcx.eq.0) then do k=1,l do j=1,mp vrx(np,j,k)=vrx(np-1,j,k) vry(np,j,k)=vry(np-1,j,k) vrz(np,j,k)=vrz(np-1,j,k) enddo enddo endif if (j3.eq.1) then if (botedge.eq.1.and.ibcy.eq.0) then do k=1,l do i=1,np vrx(i,1,k)=vrx(i,1+j3,k) vry(i,1,k)=vry(i,1+j3,k) vrz(i,1,k)=vrz(i,1+j3,k) enddo enddo endif if (topedge.eq.1.and.ibcy.eq.0) then do k=1,l do i=1,np vrx(i,mp,k)=vrx(i,mp-j3,k) vry(i,mp,k)=vry(i,mp-j3,k) vrz(i,mp,k)=vrz(i,mp-j3,k) enddo enddo endif endif endif #endif c-------------------------------------------------------- compute vorticity diagnostics nml=n*m*l c ---- standard statistics vrxmx=-1.e15 vrxmn= 1.e15 vrxav= 0. vrymx=-1.e15 vrymn= 1.e15 vryav= 0. vrzmx=-1.e15 vrzmn= 1.e15 vrzav= 0. vrxmx=globmax(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxmn=globmin(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxav=globsum(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrymx=globmax(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrymn=globmin(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vryav=globsum(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzmx=globmax(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzmn=globmin(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzav=globsum(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxav=vrxav/float(nml) vryav=vryav/float(nml) vrzav=vrzav/float(nml) vrxsd=0. vrysd=0. vrzsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(vrx(i,j,k)-vrzav)**2 tmp2(i,j,k)=(vry(i,j,k)-vryav)**2 tmp3(i,j,k)=(vrz(i,j,k)-vrzav)**2 enddo enddo enddo vrxsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrysd=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzsd=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxsd=sqrt(vrxsd/float(nml)) vrysd=sqrt(vrysd/float(nml)) vrzsd=sqrt(vrzsd/float(nml)) print 201, vrxmx,vrxmn,vrxav,vrxsd 201 format(3x,'vrxmx,vrxmn,vrxav,vrxsd:',2x,4(1x,e11.4)) print 202, vrymx,vrymn,vryav,vrysd 202 format(3x,'vrymx,vrymn,vryav,vrysd:',2x,4(1x,e11.4)) print 203, vrzmx,vrzmn,vrzav,vrzsd 203 format(3x,'vrzmx,vrzmn,vrzav,vrzsd:',2x,4(1x,e11.4)) c-------------------------------------------------------- c ---- divergence of solenoidal vorticity * dt do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ug(i,j,k)=g11*vrx(i,j,k)+g21*vry(i,j,k) vg(i,j,k)=g12*vrx(i,j,k)+g22*vry(i,j,k) wg(i,j,k)=g13*vrx(i,j,k)+g23*vry(i,j,k)+g33*vrz(i,j,k) dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) tmp3(i,j,k)=((1-icylind)*gmm(i,j,k)**2*cosa(i,j) . +icylind*gmm(i,j,k))/(gi(i,j)*gmus(k))*dnmi enddo enddo enddo call rhsdiv(ug,vg,wg,tmp3,ugc,0) ! tmp3 is Jacobian nml=n*m*l vrdvmx=-1.e15 vrdvmn= 1.e15 vrdvav= 0. vrdvmx=globmax(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvmn=globmin(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvav=globsum(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvav=vrdvav/float(nml) vrdvsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(ugc(i,j,k)-vrdvav)**2 enddo enddo enddo vrdvsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvsd=sqrt(vrdvsd/float(nml)) print 204, vrdvmx,vrdvmn,vrdvav,vrdvsd 204 format(1x,'vrdvmx,vrdvmn,vrdvav,vrdvsd:',4(1x,e11.4)) return end #endif /* VORTPL == 1 */ subroutine reystress(f,w,n1,n2,n3,iflg,lipps) include 'param.nml' include 'msg.inc' real f(1-ih:np+ih, 1-ih:mp+ih, l) real w(1-ih:np+ih, 1-ih:mp+ih, l) real frey(1-ih:np+ih, 1-ih:mp+ih, l) character*80 lhead dimension fav(l),wav(l),fwav(l),reys(l),reysd(l), 1 zcr(l),wgt(l),ar(l),rho(l),reysdiv(l),ff(n,l),ffu(n,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/skew/ w2(l) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fwz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 11) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fwz(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 4) #endif common/srprint/ itblpri nsq=1 izbar=0 xnorm=1. cpr print *,'***********************iflg=',iflg if(iflg.eq.8.or.iflg.eq.81.or.iflg.eq.82 . .or.iflg.eq.91) then izbar=0 nsq=2 endif zlam=1.e3 ntp=n3 top=(ntp-1)*dz/zlam #if (POLES == 0) il=1 ir=n1-ibcx jl=1 jr=n2-ibcy #else il=1 ir=n1 jl=1 jr=n2 #endif do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz call density profile call rhprof(rho,zcr,n3,lipps) create f*w product (for izbar=1 only) if (izbar .eq. 1) then do k=1,n3 do i=il,ir do j=jl,jr fw(i,j,k)=f(i,j,k)*w(i,j,k) enddo enddo enddo call interz(fw,fwz,fwav,wgt,n1,n2,n3) endif create interpolated fields call interz( f, fz, fav,wgt,n1,n2,n3) call interz( w, wz, wav,wgt,n1,n2,n3) compute fluxes cnorm=1. if(iflg.eq.1 .or. iflg.eq.2) cnorm=cnorm*drgnorm ip=0 do 3 kc=n3,1,-1 reys(kc)=0. if (izbar .eq. 1) then do i=il,ir do j=jl,jr reys(kc) = reys(kc) + * (fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc) enddo enddo endif if (izbar .eq. 0) then do i=il,ir do j=jl,jr frey(i,j,kc)=(fz(i,j,kc)-fav(kc))**nsq * *(wz(i,j,kc)-wav(kc))*rho(kc) reys(kc) = reys(kc) + frey(i,j,kc) enddo enddo endif cdf if (wgt(kc).eq.float(ir*jr)) then cdf reys(kc)=reys(kc)*dx*dy/cnorm if (wgt(kc).gt.0.) then reys(kc)=reys(kc)/wgt(kc) ip=ip+1 else reys(kc)=2.*reys(kc+1)-reys(kc+2) endif 3 continue if(iflg.eq.9) then do k=1,n3 w2(k)=reys(k) enddo return endif if(iflg.eq.3.and.inorm.eq.1) then iz=1 reymn=1.e30 do k=2,n3 if(reys(k).lt.reys(k-1).and.reys(k).lt.reymn) then iz=k reymn=reys(k) endif enddo zi=(iz-1)*dz wstr=(g/th00*zi*hf00)**(1./3.) tstr=hf00/amax1(wstr,1.e-15) qstr=qf00/amax1(wstr,1.e-15) print 777, zi,wstr,tstr,qstr 777 format(2x,'zi, w*, th*, q*:',4e11.4) endif compute standard deviation of Reynolds stress do 4 kc=n3,1,-1 reysd(kc)=0. if (izbar .eq. 1) then do i=il,ir do j=jl,jr reysd(kc) = reysd(kc) + * ( (fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc)*dx*dy/cnorm ccc * ((fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc) * -reys(kc))**2 enddo enddo endif if (izbar .eq. 0) then do i=il,ir do j=jl,jr reysd(kc) = reysd(kc) + * ((fz(i,j,kc)-fav(kc))**nsq*(wz(i,j,kc)-wav(kc)) * *rho(kc)*dx*dy/cnorm - reys(kc) )**2 ccc * *rho(kc)-reys(kc))**2 enddo enddo endif if (wgt(kc).gt.0.) then cdf if (wgt(kc).eq.float(ir*jr)) then reysd(kc)=reysd(kc)/wgt(kc) else reysd(kc)=2.*reysd(kc+1)-reysd(kc+2) endif 4 continue if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) xnorm=1./(wstr*tstr) if(iflg.eq.4.or.iflg.eq.41.or.iflg.eq.42) xnorm=1./wstr**3 if(iflg.eq.8.or.iflg.eq.81.or.iflg.eq.82) xnorm=1./wstr**3 if(iflg.eq.1.or.iflg.eq.2) xnorm=1./wstr**2 if(iflg.eq.5.or.iflg.eq.6) xnorm=1./qstr**2 do k=1,n3 reys(k)= reys(k)*xnorm reysd(k)=reysd(k)*xnorm*xnorm enddo endif if(iflg.eq.91) then do k=1,n3 reys(k)= reys(k)/(sqrt(amax1(1.e-10,w2(k)))**3) reysd(k)=reysd(k)/(sqrt(amax1(1.e-10,w2(k)))**3) enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 t4=-1.e10 t5=+1.e10 do k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,reys(k)) t2=amin1(t2,reys(k)) t3=amax1(t3,reysd(k)) t4=amax1(t4,reysdiv(k)) t5=amin1(t5,reysdiv(k)) enddo c ... set limits on reysd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue c print *,'reys',reys c print *,'reysdiv',reysdiv c overwrite min max for reys profiles special Nils c slim1=-1.e-3 c slim2=1.e-3 c slim3=-0.05 c slim4=0.05 call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) call wrtitl(lhead,iflg,time,1,1) call plchhq(cpux(512),cpuy(ipt1),lhead(1:43),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call plchhq(cpux(307),cpuy(50),'mean',0.015,0.,0.) call plchhq(cpux(717),cpuy(50),'st. dev.',0.015,0.,0.) is=n3-ip+1 call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(reys(is),zcr(is),ip) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(reysd(is),zcr(is),ip) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.3) then print 701 701 format(2x,' *** *** ') print 770, (reys(k),k=1,l) endif if(iflg.eq.8) then print 703 703 format(2x,' *** *** ') print 770, (reys(k),k=1,l) endif endif 200 format(e11.4,' -->',e11.4) return end subroutine inzxy(kc,f,fiz,n1,n2,n3,izcr,ispvl,nkug) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension fiz(n1,n2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common /smospv/ spval,jswt,ioffp c nkug = 0 nm=n1*n2 jswt=1 if(izcr.eq.0) then ioffp=0 spval=0.0 do i=1,n do j=1,m fiz(i,j)=f(i,j,kc) enddo enddo else ioffp=1 C# spval=1234567890. zcr=(kc-1)*dz do i=1,n do j=1,m zbr=(zcr-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fiz(i,j)=f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) else C# fiz(i,j)=spval*ispvl constant for underground points used in interpolations nkug = 123456*ispvl spval=nkug fiz(i,j)=spval endif enddo enddo endif return end subroutine inzxy3(f,fiz,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . fiz(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) c nm=n1*n2 do 100 k=1,n3 zcr=(k-1)*dz do i=1,n do j=1,m zbr=(zcr-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fiz(i,j,k)=f(i,j,kbrm) . +(f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) else fiz(i,j,k)=0. endif enddo enddo 100 continue return end subroutine interz(f,fz,fav,wgt,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(n3),wgt(n3),zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (POLES == 0) il=1 ir=n1-ibcx jl=1 jr=n2-ibcy #else il=1 ir=n1 jl=1 jr=n2 #endif do 1 kc=1,n3 zcr(kc)=(kc-1)*dz 1 continue do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fz(i,j,kc)=f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) fav(kc)=fav(kc) + fz(i,j,kc) wgt(kc)=wgt(kc) + 1. else fz(i,j,kc)=0. endif enddo enddo if (wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue return end subroutine filtplt(fl,fxyz,df,hx,hy,hz,pz) include 'param.nml' include 'msg.inc' dimension fl(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 nml=n*m*l icase=1 if(icase.eq.1) then itrz=16 df3=0.125/(dxi**2+j3*dyi**2+dzi**2) do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=1 df(i,j,k)=df3 enddo enddo enddo do it=1,itrz call lapdf(fl,fxyz,df,fxyz,hx,hy,hz,pz,0) do i=1,n do j=1,m do k=1,l fl(i,j,k)=fl(i,j,k)+fxyz(i,j,k) fxyz(i,j,k)=1 enddo enddo enddo enddo c go to 200 else itrh=16 dfh=0.25/(dxi**2+j3*dyi**2) prd= (dz/dx)**2 do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=prd df(i,j,k)=dfh enddo enddo enddo do it=1,itrh call lapdf(fl,fxyz,df,fxyz,hx,hy,hz,pz,0) do i=1,n do j=1,m do k=1,l fl(i,j,k)=fl(i,j,k)+fxyz(i,j,k) fxyz(i,j,k)=prd enddo enddo enddo enddo endif c 200 continue return end subroutine xzplot(jc,isy,f,u,w,n1,n3,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (nl2=n*l*2) dimension f(n1,n3),u(n1,n3),w(n1,n3),work(nl2) character*80 lhead common /xzfrm/ is,ie,t1x,t2x,t3x,ks,ke,t1z,t2z,t3z common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,ix0,ix1,incx,iz0,iz1,incz common/litarr/ litarfl common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) dimension xp(n) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /0/ do i=1,2000 tp(i)=0. hp(i)=1. enddo CTEST print *,'xzplot iflg :',iflg jswt=1 ioffp=0 spval=0. ilab=0 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 iswt=1 iflv=1 ivrt=0 itc=1 zct=1. + float(n3-1) litarfl=1 c ix0=4 c ix1=4 iz0=1 iz1=0 incx=3 ! density of vector in x direction incz=2 ! density of vector in z direction inita=4 initb=4 c scales for plot zlam=1.e3 ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb topzb=(ntp-1)*dz/zb*0. if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=0. xm1=360. else xml=1.e-2 xm0=-((n1-1-2*is)*0.5*dx/xml) xm1=+((n1-1-2*ie)*0.5*dx/xml) c xm0=-((icc-1-is)*dx/xml) c xm1=+((n1-icc-ie)*dx/xml) end if cccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccc create topography for mapping purposes c if(zsmx.gt.mintop) then zb2=.5/zb do i=1+is,n1-ie tp(i-is)=(zs(i,jc)+zs(i,jc+isy))*zb2-botzb hp(i-is)=(zh(i,jc)+zh(i,jc+isy))*zb2-topzb end do c endif if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif #if (COLORPL == 1) color plot create values for color map ipal =xzcol(1,iflagc) !colorpalete nclev=xzcol(2,iflagc) !number of isolines ilabl=xzcol(3,iflagc) !number of line labels zmin1=zmin(iflagc) !minimum values zmax1=zmax(iflagc) !maximum values izval1=izval(iflagc) !flag for min, max values ihlg1=ihlg(1,iflagc) !high/low labels ihcg1=ihcg(1,iflagc) !hachuring flags call sflush vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value c plot color isolines, labels call colorpl(f(1+is,1+ks),n1,n1-(is+ie),n3,n3-(ks+ke),ism,3, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1,ihlg1,ihcg1) #else if(isphere.eq.1) then t1z=0.1 t3z=1.*(33./71.) t2z=t1z+.8*t3z end if call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,1) iprint=0 if(iprint.eq.1) then print*,'t1x,t2x,t1z,t2z =',t1x,t2x,t1z,t2z print*,'xm0,xm1,bot,top =',xm0,xm1,bot,top end if create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=xzcol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else c nclv=xzcol(2,iflagc) call contin(f,cmn,cmx,cnt,nclv,n,l) c if(iflg.eq.6) cnt=0.05 endif #endif call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,bot,top,lnlg) call gstxci(1) call gsplci(1) if (ivctpl.eq.1) call velvct(u(1+is,1+ks),n1,w(1+is,1+ks), . n1,n1-(is+ie),n3-(ks+ke),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+is,1+ks),w(1+is,1+ks),work, . n1,n1-(is+ie),n3-(ks+ke),-1,ier) #if (COLORPL == 0) c plot bw isolines if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do k=1,n3 do i=1,n1 f(i,k)=-f(i,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmnn,cnt, . -1,-1,682) end if #endif if((zsmx.gt.mintop).and.(zsmx.gt.bot)) then zlam2=.5/zlam dxxml=dx/xml if(isphere.eq.1) then pi=acos(-1.) dxa=dx/rds dxxml=dxa*180./pi endif do i=1+is,n1-ie tp(i-is)=(zs(i,jc)+zs(i,jc+isy))*zlam2 c tp(i-is)=max(bot,tp(i-is)) hp(i-is)=(zh(i,jc)+zh(i,jc+isy))*zlam2 c hp(i-is)=min(top,hp(i-is)) xp(i-is)=(i-(1+is))*dxxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n1-(is+ie)) call curved(xp,hp,n1-(is+ie)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (6,6,4,8,1,1,5,0.,0.) x2=float(n1-(is+ie)) y2=float(ntp) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1x,t2x,t1z,t2z,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. c xyl=xvpl-.125*(xvpr-xvpl) c yxl=yvpb-.125*(yvpt-yvpb) xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'x (deg)',.015, 0.,0.) else call plchhq(xc,cfuy(yxl),'x (cm)',.015, 0.,0.) c call plchhq(xc,cfuy(yxl),'x/Pi',.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.015,90.,0.) end if c call plchhq(cfux(xyl),yc,'z (cm)',.015,90.,0.) call plchhq(cfux(xyl),yc,'z (km)',.015,90.,0.) call wrtitl(lhead,iflg,time,jc,2) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif c call bndary call frame 200 format('cmx,cmn,cnt:', 3e11.4) return end subroutine yzplot(ic,isx,f,u,w,n2,n3,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (ml2=m*l*2) dimension f(n2,n3),u(n2,n3),w(n2,n3),work(ml2) character*80 lhead common /yzfrm/ js,je,t1y,t2y,t3y,ks,ke,t1z,t2z,t3z common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,iy0,iy1,incy,iz0,iz1,incz common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common /plzsmax/zsmx,mintop common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) dimension xp(m) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /1/ iflv=1 ivrt=0 do i=1,2000 tp(i)=0. hp(i)=1. enddo itc=1 zct=1. + float(n3-1) iswt=1 ilab=0 litarfl=1 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 jswt=1 ioffp=0 spval=0. c iy0=4 c iy1=4 incy=2 c iz0=1 c iz1=0 incz=2 inita=4 initb=4 c zlam=1.e3 ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb topzb=(ntp-1)*dz/zb*0. if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=-90.+(1-0.5)*180./float(m) xm1=-90.+(m-0.5)*180./float(m) c xm0=-90. c xm1= 90. else xml=1.e-2 xm0=ycr(ic,1)/xml xm1=ycr(ic,m)/xml end if ccccccccccccccccccccccccccccccccc c contour plots follow ccccccccccccccccccccccccccccccccc create topography for mapping purposes c if(zsmx.gt.mintop) then zb2=.5/zb do j=1+js,n2-je tp(j-js)=(zs(ic,j)+zs(ic+isx,j))*zb2-botzb hp(j-js)=(zh(ic,j)+zh(ic+isx,j))*zb2-topzb end do c endif if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif c--------------------------------------------------------------- #if (COLORPL == 1) color plot create value for color map ipal =yzcol(1,iflagc) nclev=yzcol(2,iflagc) ilabl=yzcol(3,iflagc) zmin1=zmin(iflagc) zmax1=zmax(iflagc) izval1=izval(iflagc) ihlg1=ihlg(1,iflagc) ihcg1=ihcg(1,iflagc) vps=-(t2y-t1y)/(t2z-t1z) !vps=-1.5 call sflush call colorpl(f(1+js,1+ks),n2,n2-(js+je),n3,n3-(ke+ks),ism,3, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1,ihlg1,ihcg1) #else call set(t1y,t2y,t1z,t2z,xm0,xm1,bot,top,1) c call gslwsc(0.75) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=yzcol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,m,l) endif #endif c--------------------------------------------------------------- call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,bot,top,lnlg) iprint=0 if(iprint.eq.1) then c print*,'xvpl,xvpr,yvpb,yvpt',xvpl,xvpr,yvpb,yvpt c print*,'xwdl,xwdr,ywdb,ywdt',xwdl,xwdr,ywdb,ywdt print*,'xm0,xm1,bot,top,lnlg',xm0,xm1,bot,top,lnlg end if call gstxci(1) call gsplci(1) if (ivctpl.eq.1) call velvct(u(1+js,1),n2,w(1+js,1), . n2,n2-(js+je),n3-(ke+ks),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+js,1),w(1+js,1),work, . n2,n2-(js+je),n3-(ke+ks),-1,ier) c--------------------------------------------------------------- #if (COLORPL == 0) if (cmx.ge.cnt) then ct=cnt if (cmn.gt.ct) ct=cmn call conrec(f(1+js,1),n2,n2-(js+je),n3-(ke+ks),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do k=1,n3 do j=1,n2 f(j,k)=-f(j,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+js,1),n2,n2-(js+je),n3-(ke+ks),ct,cmnn,cnt, . -1,-1,682) end if #endif c--------------------------------------------------------------- c print*,'B:plotyz' c print*,'zsmx,mintop,bot,zlam',zsmx,mintop,bot,zlam if((zsmx.gt.mintop).and.(zsmx.gt.bot)) then zlam2=.5/zlam dyxml=dy/xml if(isphere.eq.1) then pi=acos(-1.) dya=dy/rds dyxml=dya*180./pi endif do j=1+js,n2-je tp(j-js)=(zs(ic,j)+zs(ic+isx,j))*zlam2 tp(j-js)=max(bot,tp(j-js)) hp(j-js)=(zh(ic,j)+zh(ic+isx,j))*zlam2 hp(j-js)=min(top,hp(j-js)) c xp(j-js)=0.5*(ycr(ic,j)+ycr(ic+isx,j))/xml xp(j-is)=(j-(1+js))*dyxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n2-(js+je)) call curved(xp,hp,n2-(js+je)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (3,6,4,8,1,1,5,0.,0.) x2=float(n2-(js+je)) y2=float(ntp) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1y,t2y,t1z,t2z,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'y (deg)' ,0.015, 0.,0.) else call plchhq(xc,cfuy(yxl),'y (cm)' ,0.015, 0.,0.) c call plchhq(xc,cfuy(yxl),'y/Pi',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.015,90.,0.) end if call plchhq(cfux(xyl),yc,'z (km)' ,0.015,90.,0.) c call plchhq(cfux(xyl),yc,'z/Pi' ,0.015,90.,0.) call wrtitl(lhead,iflg,time,ic,3) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) c call plchhq(cpux(512),cpuy(ipt1),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif call frame 200 format('cmx,cmn,cnt:', 3e11.4) return end subroutine xyplot(kc,f,u,v,n1,n2,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (nm2=n*m*2) dimension f(n1,n2),u(n1,n2),v(n1,n2),work(nm2) character*80 lhead common /xyfrm/ is,ie,t1x,t2x,t3x,js,je,t1y,t2y,t3y common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,ix0,ix1,incx,iy0,iy1,incy common/litarr/ litarfl common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common /plzsmax/zsmx,mintop common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /0/ dimension zsp(n,m),zhp(n,m),xp(n) jswt=1 spval=0. ioffp=0 iflv=1 ivrt=0 do i=1,2000 tp(i)=0. hp(i)=1. enddo do j=1,n2 do i=1,n1 zsp(i,j)=zs(i,j) zhp(i,j)=zh(i,j) enddo enddo iswt=1 ilab=0 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 itc=0 zct=1. + float(n2-1) litarfl=1 imp=3*itc c ix0=4 c ix1=4 c iy0=4 c iy1=4 incx=3 incy=2 inita=4 initb=4 c if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=0. xm1=360. ym0=-90.+(1-0.5)*180./float(m) ym1=-90.+(m-0.5)*180./float(m) else xml=1.e-2 yml=1.e-2 xm0=-((n1-1-2*is)*0.5*dx/xml)*0. xm1=+((n1-1-2*ie)*0.5*dx/xml)*2. ym0=-((n2-1-2*js)*0.5*dy/yml)*0. ym1=+((n2-1-2*je)*0.5*dy/yml)*2. endif ntp=n2-je nbt=1+js ym=(m-j3)*dy top=(ntp-1)*dy/yml bot=(nbt-1)*dy/yml botym=(nbt-1)*dy/ym topym=(ntp-1)*dy/ym*0. cccccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccccc create coastline for mapping purposes c yb2=.5/ym c do i=1+is,n1-ie c tp(i-is)=(ycr(i,1)+ycr(i,1+isy))*yb2-botym c hp(i-is)=(ycr(i,m)+ycr(i,m+isy))*yb2-topym c end do if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.77) then iflagc=22 !isentropic surface else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif #if (COLORPL == 1) color plot create value for color map ipal =xycol(1,iflagc) nclev=xycol(2,iflagc) ilabl=xycol(3,iflagc) zmin1=zmin(iflagc) zmax1=zmax(iflagc) izval1=izval(iflagc) ihlg1=ihlg(1,iflagc) ihcg1=ihcg(1,iflagc) vps=-(t2x-t1x)/(t2y-t1y) call sflush call colorpl(f(1+is,1+js),n1,n1-(is+ie),n2,n2-(js+je),ism,imp, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1, . ihlg1,ihcg1) #else contour plot call set(t1x,t2x,t1y,t2y,xm0,xm1,ym0,ym1,1) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=xycol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,n,m) endif #endif call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,ym0,ym1,lnlg) call gstxci(1) call gsplci(1) if(amp.gt.0.) then cgr0=0. cgrt=amp cgri=amp*.25 call setusv('LW',2000) call conrec(zsp(1+is,1+js),n1,n1-(is+ie),n2-(js+je), . cgr0,cgrt,cgri,-1,-1,-682) c call conrec(zsp(1+is,1+js),n1,n1-(is+ie),n2-(js+je), c . .1,.1,.1,-1,-1,682) call setusv('LW',1000) endif if (ivctpl.eq.1) call velvct(u(1+is,1+js),n1,v(1+is,1+js),n1, . n1-(is+ie),n2-(js+je),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+is,1+js),v(1+is,1+js),work,n1, . n1-(is+ie),n2-(js+je),-1,ier) #if (COLORPL == 0) if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f(1+is,1+js),n1,n1-(is+ie),n2-(js+je),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do j=1,n2 do i=1,n1 f(i,j)=-f(i,j) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+is,1+js),n1,n1-(is+ie),n2-(js+je),ct,cmnn,cnt, . -1,-1,682) end if #endif if(itc.eq.1.and.icylind.eq.0) then yml2=.5/yml dxxml=dx/xml do i=1+is,n1-ie tp(i-is)=(ycr(i,1)+ycr(i+is,1))*yml2 hp(i-is)=(ycr(i,m)+ycr(i+is,m))*yml2 xp(i-is)=(i-(1+is))*dxxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n1-(is+ie)) call curved(xp,hp,n1-(is+ie)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (6,6,3,6,1,1,5,0.,0.) x2=float(n1-(is+ie)) y2=float(n2-(js+je)) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1x,t2x,t1y,t2y,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'x (deg) ',0.015, 0.,0.) call plchhq(cfux(xyl),yc,'y (deg) ',0.015,90.,0.) else call plchhq(xc,cfuy(yxl),'x (cm) ',0.015, 0.,0.) call plchhq(cfux(xyl),yc,'y (cm) ',0.015,90.,0.) c call plchhq(xc,cfuy(yxl),'x/Pi',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'y/Pi',0.015,90.,0.) end if call wrtitl(lhead,iflg,time,kc,4) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) c call plchhq(cpux(512),cpuy(ipt1),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt 200 format('cmx,cmn,cnt:', 3e11.4) call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif call frame return end subroutine spplot(kc,f,n1,m1,iflg,nclv) include 'param.nml' dimension f(n1,m1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 C data alat,alon,angl/0.,-60.,0./ data alat,alon,angl/60.,-60.,0./ call contin(f,cmn,cmx,cnt,nclv,n,m) call finplt(f,m1,n1,kc,alat,alon,angl, . 0.,iflg,cmn,cmx,cnt,nclv,time) return end subroutine finplt(z,nlat,nlonp2,kc,alat,alon,angl, . rot,iflg,cmn,cmx,cnt,nclv,time) include 'param.nml' parameter (lrwk=10000,liwk=10000, nwrk=1000,isiz=100) parameter (ncra=1000, nra=10) parameter (ICA1=10*n,ICA2=10*m) integer icra(ICA1,ICA2) integer iwrk(liwk), iama(2*liwk) real rwrk(lrwk) real xwrk(nwrk),ywrk(nwrk),iarea(isiz),igrp(isiz) real xcra(ncra), ycra(ncra), iara(nra), igra(nra) real z(nlonp2,nlat), ztrue(nlonp2,nlat) real zplt(200*200) real rlat1(2),rlat2(2),rlon1(2),rlon2(2) character*80 lhead c ipt1=int(192.8+819.2)-10 call set(0.1,0.9,0.1,0.9,0.,1.,0.,1.,1) c call wrtitl(lhead,iflg,time,kc,4) c call wtstr(cpux(512),cpuy(ipt1),lhead(1:45),2,0,0) write (lhead,200) cmx,cmn,cnt 200 format('cmx,cmn,cnt:', 3e11.4) call wtstr(cpux(512),cpuy(20),lhead(1:45),2,0,0) C++++++++++++++++++++++++++++++++++++++++++++++++++ c-------------------------------------------------- c construct the plotting array c-------------------------------------------------- call conplt (z, zplt, nlonp2, nlat) call supmap(-2,0.,-90.,0.,0.,0.,0.,0.,1,-1000,0,0,ier) C++++++++++++++++++++++++++++++++++++++++++++++++++ CREATE GRID AND MAPA ON THE SPHERE C call mapint C LMAP=50000 C call arinam (MAP,LMAP) C call mapbla (MAP) C call mapgrm (MAP, XWRK, YWRK, NWRK, IAREA, IGRP, ISIZ, mask) C call frame C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE GRID INCREMENT in [deg] call mapsti ('GR - GRID INCREMENT', 0) C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE OUTLINE DATASET FOR CONTOURS C NO - no outlines C CO - continental outlines (by default) C US - US state outlines C PS - continental + US state + international political C PO - continental + international political call mapstc ('OU - OUTLINE DATASET', 'NO') C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE MAP LINE COLORS FOR SPECIFIED PARTS OF MAPA COLOR 1 - WHITE COLOR 2 - RED (BLUE) COLOR 3 - GREEN COLOR 4 - BLUE (RED) COLOR 5 - MAGNETA COLOR 6 - YELLOW COLOR 7 - BLACK call mapsti ('C1 - COLOR INDEX 1 - PERIMETER',1) call mapsti ('C2 - COLOR INDEX 2 - GRID',4) call mapsti ('C3 - COLOR INDEX 3 - LABELS',6) call mapsti ('C4 - COLOR INDEX 4 - LIMB LINE',1) call mapsti ('C5 - COLOR INDEX 5 - CONTINENTAL OUTLINES',5) call mapsti ('C6 - COLOR INDEX 6 - US STATE OUTLINES',6) call mapsti ('C7 - COLOR INDEX 7 - COUNTRY OUTLINES',7) C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE SATELITE VIEW: central point of view C alon - longitude [deg] C alat - latitude [deg] (0 .. 180) C angl - kat skretu [deg] call maproj ('SV - SATELITE VIEW', alat, alon, angl) C++++++++++++++++++++++++++++++++++++++++++++++++++ CSETING LIMITS FOR THE PROJECTION: call mapset C MA - maximum useful area specified by rlat1,rlat2,rlon1,rlon2 C CO - see manual (page 91) C LI - see manual (page 91) C AN - see manual (page 91) C PO - see manual (page 91) rlat1(1)=-90. rlat1(2)=0. rlat2(1)=90. rlat2(2)=0. rlon1(1)=-180. rlon1(2)=0. rlon2(1)=0. rlon2(2)=0. call mapset ('MA', rlat1, rlat2, rlon1, rlon2) C++++++++++++++++++++++++++++++++++++++++++++++++++ COMBINE MAPINT + MAPGRD + MAPLBL + MAPLOT |--> MAPDRW C MAPROJ,MAPSET,MAPPOS must be before MAPDRW call mapdrw C call frame C++++++++++++++++++++++++++++++++++++++++++++++++++ CPLOT ARRAY DATA ON THE SPHERE CONTOUR LEVEL SELECTION CLS: C CLS=0 - NCL,CLV will not be changed C CLS=-n - generate n contour levels from min to max value C CLS=+n - see manual (page 397) CONTOUR INTERVAL SPECIFIER CIS: C see describtion of CLS, when CLS>0, CIS is used C CIS<=0 see describtion of CIT and LIT c call cpseti('CLS - CONTOUR LEVEL SELECTION',+26) call cpseti('CLS - CONTOUR LEVEL SELECTION',0) call cpsetr('CMN - min',cmn) call cpsetr('CMX - max',cmx) call cpsetr('CIS - interval',cnt) call cpseti('MAP - mapping',1) call cpsetr('XC1 - left edge',-180.) call cpsetr('XCM - right edge',180.) call cpsetr('YC1 - bot edge',-90.) call cpsetr('YCN - top edge',90.) call cpsetr('ORV - outofrange val',1.e12) call cpseti('SET - turn off set',0) c call cprect(zplt, nlonp2, nlonp2-1, nlat+2, rwrk,lrwk,iwrk,liwk) c c call cppkcl(zplt,rwrk,iwrk) call cpcldr(zplt, rwrk, iwrk) call frame return end subroutine conplt (z, zplt, nlonp2, nlat) real z(nlonp2,nlat), zplt(nlonp2, nlat+2) do 20 j = 1,nlat do 10 i = 1,nlonp2 zplt(i,j+1) = z(i,j) 10 continue 20 continue avgn = 0 avgs = 0 do 30 i = 1,nlonp2-2 avgn = avgn + z(i,nlat) avgs = avgs + z(i,1) 30 continue avgn = avgn/(nlonp2-2) avgs = avgs/(nlonp2-2) c do 40 i = 1,nlonp2 zplt(i,1) = avgs zplt(i,nlat+2) = avgn 40 continue c if (avgs + avgn .ne. 0.) then c write (6,*) ' conplt, avgs, avgn ', avgs, avgn c do 111 i = 1,nlonp2-2 c write (6,*) 'i, s, n ', z(i,1), z(i,nlat) c 111 continue c endif return end subroutine xyzplot(f,zs3,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' C parameter (nm2=n*m*2) dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l) C dimension work(nm2) character*80 lhead return end subroutine wrtitl(lhead,iflg,time,ijk,iplf) character*80 lhead if(iplf.eq.0) then if(iflg.eq.1) write (lhead,1) time if(iflg.eq.2) write (lhead,2) time if(iflg.eq.3) write (lhead,3) time if(iflg.eq.4) write (lhead,4) time if(iflg.eq.41) write (lhead,41) time if(iflg.eq.5) write (lhead,5) time if(iflg.eq.6) write (lhead,6) time if(iflg.eq.9) write (lhead,9) time if(iflg.eq.10) write (lhead,10) time if(iflg.eq.11) write (lhead,11) time if(iflg.eq.12) write (lhead,12) time if(iflg.eq.13) write (lhead,13) time if(iflg.eq.14) write (lhead,14) time if(iflg.eq.15) write (lhead,15) time if(iflg.eq.16) write (lhead,16) time if(iflg.eq.17) write (lhead,17) time if(iflg.eq.18) write (lhead,18) time if(iflg.eq.19) write (lhead,19) time if(iflg.eq.31) write (lhead,31) time if(iflg.eq.32) write (lhead,32) time if(iflg.eq.71) write (lhead,71) time if(iflg.eq.72) write (lhead,72) time if(iflg.eq.73) write (lhead,73) time if(iflg.eq.74) write (lhead,74) time 1 format(' at time= ',f9.2) 2 format(' [K] at time= ',f9.2) 3 format(' at time= ',f9.2) 4 format(' [m/s] at time= ',f9.2) 41 format(' [m/s] at time= ',f9.2) c 4 format(' at time= ',f9.2) c 41 format(' at time= ',f9.2) 5 format(' at time= ',f9.2) 6 format(' [m/s] at time= ',f9.2) 9 format(' at time= ',f9.2) 10 format(' [g/kg] at time= ',f9.2) 11 format(' [g/kg] at time= ',f9.2) 12 format(' [g/kg] at time= ',f9.2) 31 format(' [g/kg] at time= ',f9.2) 32 format(' [g/kg] at time= ',f9.2) 13 format(' at time= ',f9.2) 14 format(' at time= ',f9.2) 15 format(' at time= ',f9.2) 16 format(' at time= ',f9.2) 17 format(' at time= ',f9.2) 18 format(' at time= ',f9.2) 19 format(' at time= ',f9.2) 71 format('vortx*dt at time= ',f9.2) 72 format('vorty*dt at time= ',f9.2) 73 format('vortz*dt at time= ',f9.2) 74 format('PV at time= ',f9.2) endif if(iplf.eq.1) then if(iflg.eq. 1) write (lhead, 101) time if(iflg.eq. 2) write (lhead, 102) time if(iflg.eq. 3) write (lhead, 103) time if(iflg.eq.31) write (lhead,1031) time if(iflg.eq.32) write (lhead,1032) time if(iflg.eq. 4) write (lhead, 104) time if(iflg.eq.41) write (lhead,1041) time if(iflg.eq.42) write (lhead,1042) time if(iflg.eq. 5) write (lhead, 105) time if(iflg.eq. 6) write (lhead, 106) time if(iflg.eq.71) write (lhead, 171) time if(iflg.eq.72) write (lhead, 172) time if(iflg.eq.73) write (lhead, 173) time if(iflg.eq.74) write (lhead, 174) time if(iflg.eq. 8) write (lhead, 108) time if(iflg.eq.81) write (lhead,1081) time if(iflg.eq.82) write (lhead,1082) time if(iflg.eq.91) write (lhead,1091) time 101 format(' )*(w-)> at time= ',f9.2) 102 format(' )*(w-)> at time= ',f9.2) 103 format(' )*(w-)> at time= ',f9.2) 1031 format(' )*(u-)> at time= ',f9.2) 1032 format(' )*(v-)> at time= ',f9.2) 104 format(' )*(w-)> at time= ',f9.2) 1041 format(' )*(u-)> at time= ',f9.2) 1042 format(' )*(v-)> at time= ',f9.2) 108 format(')**2*(w-)> at time= ',f9.2) 1081 format(')**2*(w-)> at time= ',f9.2) 1082 format(')**2*(w-)> at time= ',f9.2) 1091 format('skewness at time= ',f9.2) 105 format(' )*(w-)> at time= ',f9.2) 106 format(' )*(w-)> at time= ',f9.2) 171 format(')*(w-)> at time=',f9.2) 172 format(')*(w-)> at time=',f9.2) 173 format(')*(w-)> at time=',f9.2) 174 format(')*(w-)> at time=',f9.2) endif if(iplf.eq.2) then jc=ijk if(iflg.eq.1) write (lhead,201) time,jc if(iflg.eq.2) write (lhead,202) time,jc if(iflg.eq.3) write (lhead,203) time,jc if(iflg.eq.4) write (lhead,204) time,jc if(iflg.eq.41) write (lhead,2041) time,jc if(iflg.eq.5) write (lhead,205) time,jc if(iflg.eq.6) write (lhead,206) time,jc if(iflg.eq.9) write (lhead,209) time,jc if(iflg.eq.10) write (lhead,210) time,jc if(iflg.eq.11) write (lhead,211) time,jc if(iflg.eq.12) write (lhead,212) time,jc if(iflg.eq.13) write (lhead,213) time,jc if(iflg.eq.14) write (lhead,214) time,jc if(iflg.eq.15) write (lhead,215) time,jc if(iflg.eq.16) write (lhead,216) time,jc if(iflg.eq.17) write (lhead,217) time,jc if(iflg.eq.18) write (lhead,218) time,jc if(iflg.eq.19) write (lhead,219) time,jc if(iflg.eq.31) write (lhead,231) time,jc if(iflg.eq.32) write (lhead,232) time,jc if(iflg.eq.71) write (lhead,271) time,jc if(iflg.eq.72) write (lhead,272) time,jc if(iflg.eq.73) write (lhead,273) time,jc if(iflg.eq.74) write (lhead,274) time,jc 201 format('theta perturbation at time= ',f9.2,' j=',i4) c 202 format('isentropes [K] at time= ',f9.2,' j=',i4) 202 format('log isentropes [K] at time= ',f9.2,' j=',i4) 203 format('press perturbation at time= ',f9.2,' j=',i4) 204 format('u [m/s] at time= ',f9.2,' j=',i4) 2041 format('v [m/s] at time= ',f9.2,' j=',i4) c 204 format('u perturbation at time= ',f9.2,' j=',i4) c2041 format('v perturbation at time= ',f9.2,' j=',i4) 205 format('omega at time= ',f9.2,' j=',i4) 206 format('w [m/s] at time= ',f9.2,' j=',i4) 209 format('div(rho*v)*dt/rho at time= ',f9.2,' j=',i4) 210 format('qv [g/kg] at time= ',f9.2,' j=',i4) 211 format('qc [g/kg] at time= ',f9.2,' j=',i4) 212 format('qr [g/kg] at time= ',f9.2,' j=',i4) 231 format('qia [g/kg] at time= ',f9.2,' j=',i4) 232 format('qib [g/kg] at time= ',f9.2,' j=',i4) 213 format('rh at time= ',f9.2,' j=',i4) 214 format('thetav at time= ',f9.2,' j=',i4) 215 format('Km*dt/Dx**2 at time= ',f9.2,' j=',i4) 216 format('Ri at time= ',f9.2,' j=',i4) 217 format('chemical A at time= ',f9.2,' j=',i4) 218 format('chemical B at time= ',f9.2,' j=',i4) 219 format('chemical C at time= ',f9.2,' j=',i4) 271 format('vortx*dt at time= ',f9.2,' j=',i4) 272 format('vorty*dt at time= ',f9.2,' j=',i4) 273 format('vortz*dt at time= ',f9.2,' j=',i4) 274 format('pv at time= ',f9.2,' j=',i4) endif if(iplf.eq.3) then ic=ijk if(iflg.eq.1) write (lhead,301) time,ic if(iflg.eq.2) write (lhead,302) time,ic if(iflg.eq.3) write (lhead,303) time,ic if(iflg.eq.4) write (lhead,304) time,ic if(iflg.eq.41) write (lhead,3041) time,ic if(iflg.eq.5) write (lhead,305) time,ic if(iflg.eq.6) write (lhead,306) time,ic if(iflg.eq.9) write (lhead,309) time,ic if(iflg.eq.10) write (lhead,310) time,ic if(iflg.eq.11) write (lhead,311) time,ic if(iflg.eq.12) write (lhead,312) time,ic if(iflg.eq.13) write (lhead,313) time,ic if(iflg.eq.14) write (lhead,314) time,ic if(iflg.eq.15) write (lhead,315) time,ic if(iflg.eq.16) write (lhead,316) time,ic if(iflg.eq.17) write (lhead,317) time,ic if(iflg.eq.18) write (lhead,318) time,ic if(iflg.eq.19) write (lhead,319) time,ic if(iflg.eq.31) write (lhead,331) time,ic if(iflg.eq.32) write (lhead,332) time,ic if(iflg.eq.71) write (lhead,371) time,ic if(iflg.eq.72) write (lhead,372) time,ic if(iflg.eq.73) write (lhead,373) time,ic if(iflg.eq.74) write (lhead,374) time,ic 301 format('theta perturbation at time= ',f9.2,' i=',i4) c 302 format('isentropes [K] at time= ',f9.2,' i=',i4) 302 format('log isentropes [K] at time= ',f9.2,' i=',i4) 303 format('press perturbation at time= ',f9.2,' i=',i4) 304 format('u [m/s] at time= ',f9.2,' i=',i4) 3041 format('v [m/s] at time= ',f9.2,' i=',i4) c 304 format('u perturbation at time= ',f9.2,' i=',i4) c3041 format('v perturbation at time= ',f9.2,' i=',i4) 305 format('omega at time= ',f9.2,' i=',i4) 306 format('w [m/s] at time= ',f9.2,' i=',i4) 309 format('div(rho*v)*dt/rho at time= ',f9.2,' i=',i4) 310 format('qv [g/kg] at time= ',f9.2,' i=',i4) 311 format('qc [g/kg] at time= ',f9.2,' i=',i4) 312 format('qr [g/kg] at time= ',f9.2,' i=',i4) 331 format('qia [g/kg] at time= ',f9.2,' i=',i4) 332 format('qib [g/kg] at time= ',f9.2,' i=',i4) 313 format('rh at time= ',f9.2,' i=',i4) 314 format('thetav at time= ',f9.2,' i=',i4) 315 format('Km*dt/Dx**2 at time= ',f9.2,' i=',i4) 316 format('Ri at time= ',f9.2,' i=',i4) 317 format('chemical A at time= ',f9.2,' i=',i4) 318 format('chemical B at time= ',f9.2,' i=',i4) 319 format('chemical C at time= ',f9.2,' i=',i4) 371 format('vortx*dt at time= ',f9.2,' i=',i4) 372 format('vorty*dt at time= ',f9.2,' i=',i4) 373 format('vortz*dt at time= ',f9.2,' i=',i4) 374 format('pv at time= ',f9.2,' i=',i4) endif if(iplf.eq.4) then kc=ijk if(iflg.eq.1) write (lhead,401) time,kc if(iflg.eq.2) write (lhead,402) time,kc if(iflg.eq.3) write (lhead,403) time,kc if(iflg.eq.4) write (lhead,404) time,kc if(iflg.eq.41) write (lhead,4041) time,kc if(iflg.eq.5) write (lhead,405) time,kc if(iflg.eq.6) write (lhead,406) time,kc if(iflg.eq.9) write (lhead,409) time,kc if(iflg.eq.10) write (lhead,410) time,kc if(iflg.eq.11) write (lhead,411) time,kc if(iflg.eq.12) write (lhead,412) time,kc if(iflg.eq.13) write (lhead,413) time,kc if(iflg.eq.14) write (lhead,414) time,kc if(iflg.eq.15) write (lhead,415) time,kc if(iflg.eq.16) write (lhead,416) time,kc if(iflg.eq.17) write (lhead,417) time,kc if(iflg.eq.18) write (lhead,418) time,kc if(iflg.eq.19) write (lhead,419) time,kc if(iflg.eq.31) write (lhead,431) time,kc if(iflg.eq.32) write (lhead,432) time,kc if(iflg.eq.71) write (lhead,471) time,kc if(iflg.eq.72) write (lhead,472) time,kc if(iflg.eq.73) write (lhead,473) time,kc if(iflg.eq.74) write (lhead,474) time,kc if(iflg.eq.77) write (lhead,477) time,kc 401 format('theta perturbation at time= ',f9.2,' k=',i4) c 402 format('isentropes [K] at time= ',f9.2,' k=',i4) 402 format('log isentropes [K] at time= ',f9.2,' k=',i4) 403 format('press perturbation at time= ',f9.2,' k=',i4) 404 format('u [m/s] at time= ',f9.2,' k=',i4) 4041 format('v [m/s] at time= ',f9.2,' k=',i4) c 404 format('u perturbation at time= ',f9.2,' k=',i4) c4041 format('v perturbation at time= ',f9.2,' k=',i4) 405 format('omega at time= ',f9.2,' k=',i4) 406 format('w [m/s] at time= ',f9.2,' k=',i4) 409 format('div(rho*v)*dt/rho at time= ',f9.2,' k=',i4) 410 format('qv [g/kg] at time= ',f9.2,' k=',i4) 411 format('qc [g/kg] at time= ',f9.2,' k=',i4) 412 format('qr [g/kg] at time= ',f9.2,' k=',i4) 431 format('qia [g/kg] at time= ',f9.2,' k=',i4) 432 format('qib [g/kg] at time= ',f9.2,' k=',i4) 413 format('rh at time= ',f9.2,' k=',i4) 414 format('thetav at time= ',f9.2,' k=',i4) 415 format('Km*dt/Dx**2 at time= ',f9.2,' k=',i4) 416 format('Ri at time= ',f9.2,' k=',i4) 417 format('chemical A at time= ',f9.2,' k=',i4) 418 format('chemical B at time= ',f9.2,' k=',i4) 419 format('chemical C at time= ',f9.2,' k=',i4) 471 format('vortx*dt at time= ',f9.2,' k=',i4) 472 format('vorty*dt at time= ',f9.2,' k=',i4) 473 format('vortz*dt at time= ',f9.2,' k=',i4) 474 format('pv at time= ',f9.2,' k=',i4) 477 format('isentropic sufaces at time= ',f9.2,' k=',i4) endif if(iplf.eq.5) then if(iflg.eq.16) write (lhead,516) time 516 format('Ri in 3D at time= ',f9.2) endif CTEST print *,lhead return end subroutine contin(f,cmin,cmax,delta,nlev,n,m) dimension f(n,m) common /smospv/ spval,jswt,ioffp nm=n*m cmin=1.e-11 cmax=1.e-11 delta=1.e-10 cmx=-1.e15 cmn= 1.e15 if(ioffp.eq.0) then do i=1,nm cmx=amax1(cmx,f(i,1)) cmn=amin1(cmn,f(i,1)) enddo else do i=1,nm if(f(i,1).ne.spval) then cmx=amax1(cmx,f(i,1)) cmn=amin1(cmn,f(i,1)) endif enddo endif del=(cmx-cmn)/float(nlev) if(del.lt.1.e-10) return t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**(it) if(delta.lt.del) delta=2.*delta t=cmn/delta+sign(1.e-3,cmn) it=int(t) cmin=float(it)*delta if(cmin.le.cmn) cmin=float(it+1)*delta t=cmx/delta+sign(1.e-3,cmx) it=int(t) cmax=float(it)*delta if(cmax.ge.cmx) cmax=float(it-1)*delta cmax=cmax*(1.+sign(1.e-7,cmax)) delta=(cmax-cmin)/float(nlev) CTEST print *,'cmin, cmax, delta:',cmin,cmax,delta,nlev return end subroutine plothise(f,npl,ndm) include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real f(ndm,2),tm(nth) character*80,lhead C common// tm(nth) dtmn=dt/60. do k=1,ndm tm(k)=(k-1)*dtmn enddo fmax=-1.e15 fmin= 1.e15 do k=1,npl fmin=amin1(fmin,f(k,1),f(k,2)) fmax=amax1(fmax,f(k,1),f(k,2)) enddo tmax=(npl-1)*dtmn tmin=0. i1=int(102.4+409.6) ipt1=int(192.8+819.2) ipt1=ipt1-50 #if (GKS == 1) call set (.2,.95,.2,.8,tmin,tmax,fmin,fmax,1) call gaseti('LTY',1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,100) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'ekn/tke',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,f(1,1),npl) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(tm,f(1,2),npl) call frame #endif 100 format('history of global and ') return end subroutine plotdrag(f1,f2,ntd) include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real f1(nth),f2(nth),fx(nth),fy(nth),tm(nth) character*80,lhead C common// fx(nth),fy(nth),tm(nth) dtmn=dt/60. do k=2,ntd-1 tm(k)=float(k)*dtmn fx(k)=(f1(k-1)+2.*f1(k)+f1(k+1))*.25 fy(k)=(f2(k-1)+2.*f2(k)+f2(k+1))*.25 enddo tm(1)=dtmn fx(1)=f1(1) fy(1)=f2(1) tm(ntd)=float(ntd)*dtmn fx(ntd)=f1(ntd) fy(ntd)=f2(ntd) fxmax=-1.e15 fxmin= 1.e15 fymax=-1.e15 fymin= 1.e15 do k=1,ntd fxmin=amin1(fxmin,fx(k)) fxmax=amax1(fxmax,fx(k)) fymin=amin1(fymin,fy(k)) fymax=amax1(fymax,fy(k)) enddo c tmax=ntd*dtmn c tmin=0. tmax=nth*dtmn tmin=dtmn #if (GKS == 1) CTEST print *,'fxmin,fxmax:',fxmin,fxmax CTEST print *,'fymin,fymax:',fymin,fymax if(fxmin.eq.fxmax) goto 98 i1=int(102.4+409.6) ipt1=int(192.8+819.2) ipt1=ipt1-50 call set (.2,.95,.2,.8,tmin,tmax,fxmin,fxmax,1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,100) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'drgx/drgnorm',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,fx,ntd) call frame 98 if(fymin.eq.fymax) goto 99 if(j3.eq.1)then call set (.2,.95,.2,.8,tmin,tmax,fymin,fymax,1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,101) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'drgy/drgnorm',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,fy,ntd) call frame endif 99 continue #endif 100 format('mountain wave drag - x component') 101 format('mountain wave drag - y component') return end #endif #if (V5D == 1) subroutine vis5d_out(u,v,w,ox,oy,oz,th,p,div, 1 qv,qc,qr,qia,qib,tke,rhf,inr) include 'param.nml' include 'msg.inc' include 'vrtstr.mds' include 'param.v5d' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . div(1-ih:np+ih,1-ih:mp+ih,l), . rhf(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz0(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz0(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue (1-ih:np+ih,1-ih:mp+ih,l), . ve (1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/sgscnst/ ceps,cL,cm,cs,prndt common/stresd/ diagstr(8),ivis,irid,itstr integer v5dcreate,v5dclose C 5-D grid limits, must match those in v5d.h!!! integer NVARS, NTIMES, NROWS, NCOLUMNS, NLEVELS C--------------- C Missing values C--------------- real*4 MISSING integer IMISSING parameter (MISSING=1.0E35) parameter (IMISSING=-987654) C------------------- C Rest declarations C------------------- parameter (NVARS=30) parameter (NTIMES=1) parameter (NROWS=500) parameter (NCOLUMNS=500) parameter (NLEVELS=200) integer nr, nc, nl(NVARS) integer numtimes integer numvars character*10 varnamec character*10 varname(NVARS) integer dates(1) integer times(1) integer compressmode integer projection real*4 proj_args(100) integer vertical real*4 vert_args(NLEVELS) c-------------- c Local varlues c-------------- character*13 outname character*3 outn data nl/NVARS*0.0/ data varname/NVARS*' '/ data proj_args/100*0.0/ data vert_args/NLEVELS*0.0/ #include "vrtstr.fnc" ibupl=1 ithpl=1 iprpl=1 iuvpl=1 ivvpl=1 ioxpl=1 ioypl=1 iozpl=1 iwvpl=1 idvpl=1 iripl=1 iqvpl=0 iqcpl=0 iqrpl=0 irhpl=0 ithvpl=0 ikmpl=1 iqial=0 iqibl=0 nml=n*m*l nm=n*m if(j3.eq.0) then ivvpl=0 endif iqvpl=iqvpl*moist iqcpl=iqcpl*moist iqrpl=iqrpl*moist irhpl=irhpl*moist ithvpl=ithvpl*moist iqial=(iqial*moist)*iceab iqibl=(iqibl*moist)*iceab ikmpl=ikmpl*itke iripl=iripl*irid c------------------------------- c ivar is an total output fields INVARS=ibupl+ithpl+iprpl+iuvpl+ivvpl+iwvpl+ioxpl+ioypl+iozpl+ 1 idvpl+iripl+iqvpl+iqcpl+iqrpl+irhpl+ithvpl+ikmpl+ 2 iqial+iqibl c---------------------------------- cnumber of time steps and variables numtimes=1 numvars=INVARS c------------------------------- create output file name outname(1:1)='a' if (inr.lt.10) then write (outn(1:1), '(I1)') 0 write (outn(2:2), '(I1)') 0 write (outn(3:3), '(I1)') inr else if (inr.lt.100) then write (outn(1:1), '(I1)') 0 write (outn(2:3), '(I2)') inr else if (inr.lt.1000) then write (outn(1:3), '(I3)') inr else outn(1:3)='99Q' endif outname(2:4)=outn(1:3) outname(5:13)='outpt.v5d' c--------------------------------------------------------- cinitialize actual time in each time step in format HHMMSS itime_0=int(time) sec_0=time-float(itime_0) if(sec_0.gt.0) then isec=int(sec_0*60) elseif(sec_0.lt.0) then isec=int((100-sec_0)*60) else isec=0 endif ihours=int(time/60) imint_0=ihours*60 mint_0=float(imint_0) if(mint_0.gt.time) then ihours=ihours-1 imint=60-int(mint_0-time) elseif(mint_0.lt.time) then imint=int(time-mint_0) else imint=0 endif itimes=ihours*10000+imint*100+isec data (dates(i),i=1,NTIMES) / 97130 / do i=1,NTIMES times(i)=itimes enddo c--------------------------------------------------------- cinitialize compress mode (1, 2 or 4 bytes per grid point) data compressmode / 1 / c------------------------------------------- cnumber of rows(nr), columns(nc), levels(nl) convert axis left iconv=1, right conv=-1 if(j3.eq.0) then nr=2 nc=nd else if(abs(iconv).eq.1) then nr=md nc=nd else nr=nd nc=md endif endif do i=1,INVARS nl(i)=ld enddo ast=float(idiv) cprojection mode projection=0 if(projection.eq.0) then ! Generic rectilinear C This is a linear, regularly-spaced coordinate system with no implied units. C This system is useful when your data is not related to Earth cooredinates C N/S coordinates increase upward, E/W coordinates increase to the left. C C proj_args(1) = NorthBound: Northern boundary of 3-D box C proj_args(2) = WestBound : Western boundary of 3-D box C proj_args(3) = RowInc : Increment between grid columns C proj_args(4) = ColInc : Increment between grid rows ddy=ast*dy ddx=ast*dx if(j3.eq.1) then if(iconv.eq.1) then proj_args(1)=(md-1)*ddy proj_args(2)=-(nd-1)*ddx proj_args(3)=ddy proj_args(4)=ddx else if(iconv.eq.-1) then proj_args(1)=(md-1)*ddy proj_args(2)=-(nd-1)*ddx proj_args(3)=ddy proj_args(4)=ddx else if(iconv.eq.0) then proj_args(1)=(nd-1)*ddx proj_args(2)=-(md-1)*ddy proj_args(3)=ddx proj_args(4)=ddy endif endif if(j3.eq.0) then C Vis5D accept only 2D fileds so in 2D create two equal surfaces C with very small (almost unvisible) distace in Y direction (or X C direction if the surfaces are rotated) - usually dx is efficient proj_args(1)=0. proj_args(2)=0. ! (nn1-1)*ddx proj_args(3)=ddx proj_args(4)=ddx endif endif if(projection.eq.1) then ! Cylindrical equidistant C This is the rectangular latitude/longitude coordinate system. C latitude increases to the North (upward in the graphical display) C longitude increases to the West (leftward in the graphical display; positive west latitude). C C proj_args(1) = NorthBound: Northern boundary of 3-D box in deg of latitude [-90S,90N] C proj_args(1) = WestBound : Western boundary of 3-D box in deg of longitude [-180E,180W] C proj_args(1) = RowInc : Increment between grid rows in deg of latitude [> 0] C proj_args(1) = ColInc : Increment between grid columns in deg of longitude [> 0] ! Torino orography between 7E-9E 44N-46N, iconv must be =1 ! ! proj_args(1)= 46. ! proj_args(2)=-7. ! proj_args(3)=(9.-7.)/float(nd-1) ! proj_args(4)=(46-44.)/float(md-1) ! ! Oklahoma City ! ! proj_args(1)=35.5 ! 35.4719 ! proj_args(2)=97.5 ! 97.5221 ! proj_args(3)=0.000045 ! proj_args(4)=0.000048 proj_args(1)=rlatc proj_args(2)=rlonc*(-1.) proj_args(3)=dlatc proj_args(4)=dlonc endif if(projection.eq.2) then ! Lambert conformal/Polar Stereo C This is a conic projection defined by the following six parameters. C C Lat1, Lat2: First and second standard latitudes in the range [-90S,90N]. C Define where the imaginary cone intersects the sphere of the Earth. C Must have the same sign, Lat1 must be greater than or equal to Lat2. C PoleRow, PoleCol: indicate the position of the north or south pole with respect to C 3-D grid coordinate system. These values may be outside the 3-D grid. C If Lat1 and Lat2 >0, north pole is assumed, else, south pole is assumed. C CentLon: Central longitude: indicates which longitude is parallel to 3-D grid columns. C ColInc: Increment between grid columns at the central longit and standard latit [km] C This parameter controls the scale of the projection. endif if(projection.eq.3) then ! Rotated equidistant C An aximuthal stereographic projection defined by five parameters: C C CentLat, CentLon: Latitude and longitude of the center of projection. C The apex of the imaginary cone will be over this coordinate. C CentRow, CentCol: Row and column of the center of projection. C The grid row and column indicated will be at center of the projection. C These values may be outside the 3-D box. C ColInc: Increment (spacing) between grid columns in km at center of the projection. C This parameter controls the scale of the projection. endif c--------------------------------------------------------- cvertical coordinate system c------------------------- vertical=2 if(vertical.eq.0) then ! Equally spaced, generic units vert_args(1)=0. vert_args(2)=ast*dz endif if(vertical.eq.1) then ! Equally spaced, kilometers zlam=1000. vert_args(1)=0. vert_args(2)=ast*dz/zlam endif if(vertical.eq.2) then ! Unequally spaced, kilometers C This is a linear vertical coordinate system in which grid levels C can be unequally spaced. The coordinate system is defined by an C array of N height parameters where N is the number of levels in C the 3-D grids. If the number of grid levels is different for each C variable, N is the maximum number of grid levels. C C Height(1): Height of first (bottom) grid level in km C Height(2): Height of second grid level in km C ... ... C Height(N): Height of Nth (top) grid level in km C C Note: Note that the Height values must increase with N. C C Height(1) = 0.0 C Height(2) = 0.1 C Height(3) = 0.2 C Height(4) = 0.3 C Height(5) = 0.4 C Height(6) = 0.6 C Height(7) = 0.8 C Height(8) = 1.0 C Height(9) = 1.3 C Height(10) = 1.6 C C It is also possible to display the vertical axis on a logarithmic C scale. This is done with the -log command line option when you C start vis5d. In this case, the vertical axis is logarithmic C with respect to height but linear with respect to pressure. The C relationship between height (H) and pressure (P) is: C C P = 1012.5 * exp[ H / -7.2 ] C H = -7.2 * Ln[ P / 1012.5 ] C C The constants 1012.5 and -7.2 are just defaults which can C be overriden when you specify the -log option. do k=1,l vert_args(k)=zstr(k) enddo endif if(vertical.eq.3) then ! Unequally spaced, milibars C This is a linear vertical coordinate system in which grid levels can C be unequally spaced. The coordinate system is defined by an array C of N pressure parameters where N is the number of levels in the 3-D C grids. If the number of grid levels is different for each variable, C N is the maximum number of grid levels. C C Pressure(1): Pressure of first (bottom) grid level in km C Pressure(2): Pressure of second grid level in km C ... ... C Pressure(N): Pressure of Nth (top) grid level in km C C Note: Note that the Pressure values must decrease with N. C C For the purposes of calculating wind trajectories, Vis5D assumes C the relationship between height (H) and pressure (P) is: C C P = 1012.5 * exp[ H / -7.2 ] C H = -7.2 * Ln[ P / 1012.5 ] endif c---------------------- create name of variable i=1 if(ibupl.eq.1) then varname(i)='bouyancy ' i=i+1 endif if(ithpl.eq.1) then varname(i)='T ' i=i+1 endif if(iprpl.eq.1) then varname(i)='p_rho' i=i+1 endif if(iuvsf.eq.0) then if(iuvpl.eq.1) then varname(i)='U' i=i+1 endif if(ivvpl.eq.1) then varname(i)='V' i=i+1 endif else if(iuvpl.eq.1) then varname(i)='V' i=i+1 endif if(ivvpl.eq.1) then varname(i)='U' i=i+1 endif endif if(iwvpl.eq.1) then varname(i)='W' i=i+1 endif if(ioxpl.eq.1) then varname(i)='ox' i=i+1 endif if(ioypl.eq.1) then varname(i)='oy' i=i+1 endif if(iozpl.eq.1) then varname(i)='oz' i=i+1 endif if(idvpl.eq.1) then varname(i)='divergence' i=i+1 endif if(iqvpl.eq.1) then varname(i)='Q_v' i=i+1 endif if(iqcpl.eq.1) then varname(i)='Q_c' i=i+1 endif if(iqrpl.eq.1) then varname(i)='Q_r' i=i+1 endif if(iqial.eq.1) then varname(i)='ice_A' i=i+1 endif if(iqibl.eq.1) then varname(i)='ice_B' i=i+1 endif if(irhpl.eq.1) then varname(i)='R_h' i=i+1 endif if(ithvpl.eq.1) then varname(i)='th_virt' i=i+1 endif if(ikmpl.eq.1) then varname(i)='TKE' i=i+1 endif if(iripl.eq.1) then varname(i)='R_i' i=i+1 endif if((i-1).ne.INVARS) 1 print *,'NUMBER OF FILES:',i,' INVAR:',INVARS c-------------------------------------------------------------- c Create the v5d file. c------------------------- if(mype.eq.0) then print *,'v5dcreate: outname: ', outname print *,'v5dcreate: numtimes:', numtimes print *,'v5dcreate: numvars :', numvars print *,'v5dcreate: nr :', nr print *,'v5dcreate: nc :', nc print *,'v5dcreate: nl :', nl print *,'v5dcreate: varname :', varname print *,'v5dcreate: times :', times print *,'v5dcreate: dates :', dates print *,'v5dcreate: compress:', compressmode print *,'v5dcreate: project :', projection print *,'v5dcreate: proj_arg:', proj_args(1:4) print *,'v5dcreate: vertical:', vertical print *,'v5dcreate: vert_arg:', vert_args(1:2) no = v5dcreate( outname, numtimes, numvars, nr, nc, nl, * varname, times, dates, compressmode, * projection, proj_args, vertical, vert_args ) if (no .eq. 0) then print *,'CREATE OF THE OUPUT FIELDS is FAILED' else print *,'CREATE OF THE OUPUT FIELDS is DONE' endif endif c----------------------------------------------------------------- c YOU MAY CALL v5dsetlowlev OR v5dsetunits HERE. SEE README FILE. c----------------------- maxnl = nl(1) do i=1,numvars if (nl(i) .gt. maxnl) then maxnl = nl(i) endif enddo ! if(mype.eq.0) then ! do i=1,numvars ! if(ibupl .eq.1) call v5dsetunits(i, " " ) ! if(ithpl .eq.1) call v5dsetunits(i, "K" ) ! if(iprpl .eq.1) call v5dsetunits(i, "bar/dt" ) ! if(iuvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ivvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(iwvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ioxpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ioypl .eq.1) call v5dsetunits(i, "m/s" ) ! if(iozpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(idvpl .eq.1) call v5dsetunits(i, " " ) ! if(iqvpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqcpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqrpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqial .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqibl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(irhpl .eq.1) call v5dsetunits(i, " " ) ! if(ithvpl.eq.1) call v5dsetunits(i, "K" ) ! if(ikmpl .eq.1) call v5dsetunits(i, " " ) ! if(iripl .eq.1) call v5dsetunits(i, " " ) ! enddo ! endif c-------------------------------- check if compute topografy needed sumtopo=0. do j=1,mp do i=1,np sumtopo=sumtopo+zs(i,j) enddo enddo sumtopo=globsum(sumtopo,1,1,1,1,1,1,1,1,1,1,1,1) itrans=0 if(sumtopo.gt.1.) itrans=1 ! if(mype.eq.0) print *,'sumtopo:',sumtopo,itrans c-------------------------------------------------------------- c write the 3-D grid to the v5d file c-------------------------------------------------------------- do it=1,numtimes iv=1 c------------------------ c B o u y a n c y c------------------------ if(ibupl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= (th(i,j,k)+the(i,j,k))/the(i,j,k)-1. enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Potential temperature c------------------------ if(ithpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Presure perturbation c------------------------ if(iprpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= p(i,j,k)*rho(i,j,k)*2.*dti enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c U - v e l o c i t y c------------------------ if(iuvpl.eq.1) then if(itrans.eq.1) then call transform(u,fxyz0,100) ! call transform(u,fxyz0,2) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(u ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c V - v e l o c i t y c------------------------ if(ivvpl.eq.1) then if(itrans.eq.1) then call transform(v,fxyz0,100) ! call transform(v,fxyz0,3) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(v ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c W - v e l o c i t y c------------------------ if(iwvpl.eq.1) then if(itrans.eq.1) then call transform(w,fxyz0,100) ! call transform(w,fxyz0,4) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(w ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega X - v e l o c i t y c------------------------ if(ioxpl.eq.1) then if(itrans.eq.1) then call transform(ox,fxyz0,100) ! call transform(ox,fxyz0,42) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(ox ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega Y - v e l o c i t y c------------------------ if(ioypl.eq.1) then if(itrans.eq.1) then call transform(oy,fxyz0,100) ! call transform(oy,fxyz0,43) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(oy ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega Z - v e l o c i t y c------------------------ if(iozpl.eq.1) then if(itrans.eq.1) then call transform(oz,fxyz0,100) ! call transform(oz,fxyz0,41) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(oz ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c D i v e r g e n c e c------------------------ if(idvpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= div(i,j,k)*dt enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c-------------------------- c Water vapour mixong ratio c-------------------------- if(iqvpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qv(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Cloud water mixing ratio c------------------------ if(iqcpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qc(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Rain water mixing ratio c------------------------- if(iqrpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qr(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Ice A mixing ratio c------------------------- if(iqial.eq.1) then do k=1,lic do j=1,micp do i=1,nicp fxyz(i,j,k)=qia(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Ice B mixing ratio c------------------------- if(iqibl.eq.1) then do k=1,lic do j=1,micp do i=1,nicp fxyz(i,j,k)=qib(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Relative - humidity c------------------------ if(irhpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=rhf(i,j,k) enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c T h e t a - virtual c------------------------ if(ithvpl.eq.1) then epsb=rv/rg-1. if(moist.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k) enddo enddo enddo endif if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c T K E c------------------------ if(ikmpl.eq.1) then ccc if(j3.eq.1) deltl=(dx*dy*dz)**(1./3.) if(j3.eq.1) deltl=(dx+dy+dz)/3. if(j3.eq.0) deltl=sqrt(dx*dz) deltc=sqrt(dx**2+j3*dy**2+dz**2) do k=1,lkv do j=1,mkvp do i=1,nkvp coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 ! fxyz(i,j,k)=tke(i,j,k)**2 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c R i c h a r d s o n c------------------------ if(iripl.eq.1) then if(itrans.eq.1) then call transform(ri,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(ri ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c E n d c------------------------ enddo c------------------------------------------------------------- c close the v5d file and exit c-------------------------------- if(mype.eq.0) then no = v5dclose() if (no .eq. 0) then print *,'V5D_FILE NOT SAVED __ SAVING FAILED' endif endif return end subroutine v5dwrite0(f,iconv0,IV,IT,varname) include 'param.nml' include 'msg.inc' include 'param.v5d' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension f(1-ih:np+ih, 1-ih:mp+ih, l) integer v5dwrite character*10 varname #if (PARALLEL == 0) real*4 fxyz(np,mp,l) real*4 fyxz(mp,np,l) if(iconv.eq.1) then do k=1,l do j=1,mp do i=1,np fyxz(j,i,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz ) else if(iconv.eq.-1) then do k=1,l do j=1,mp do i=1,np fyxz(m-j+1,i,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz ) do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fxyz ) endif if (ierr.eq.0) then print *,'WRITE ',varname,' FAILED' endif #else call mybarrier() if(mype.eq.0) then if(iconv.eq.0) then call v5dcollect0(f,iconv0,IV,IT,nd,md,varname) else call v5dcollect0(f,iconv0,IV,IT,md,nd,varname) endif else call v5dcollectk(f) endif #endif return end #if (PARALLEL > 0) subroutine v5dcollect0(datarr,iconv0,IV,IT,n1,n2,varname) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' include 'param.v5d' #include "msg.lnk" #include "msg.lnp" ! common/blocktempv/tmparray(np,mp,l) dimension tmparray(np,mp,ld) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) real*4 temp(n1,n2,ld) character*10 varname iproc=0 npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 ! do k=1,ld ! do j=1,n2 ! do i=1,n1 ! temp(i,j,k)=-9.9999999999999 ! end do ! end do ! end do if(iconv.eq.0) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ia-nd1+1,ja-md1+1,k-ld1+1)=datarr(i,j,k) end do end do end do else if (iconv.eq. 1) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ja-md1+1,ia-nd1+1,k-ld1+1)=datarr(i,j,k) end do end do end do else if (iconv.eq.-1) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) then temp(md2-(ja-md1+1)+1,ia-nd1+1,k-ld1+1)=datarr(i,j,k) endif end do end do end do endif #if (PARALLEL > 0) nmlp=np*mp*ld do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 2) fsg=float(iproc) call MPI_Send(fsg,1,DC_TYPE,iproc,iproc,MPI_COMM_EULAG,ierr) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 1000+iproc, . MPI_COMM_EULAG, status, ierr) #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 if(iconv.eq.0) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ia-nd1+1,ja-md1+1,k)=tmparray(i,j,k) end do end do end do else if (iconv.eq. 1) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ja-md1+1,ia-nd1+1,k)=tmparray(i,j,k) end do end do end do else if (iconv.eq.-1) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) then temp(md2-(ja-md1+1)+1,ia-nd1+1,k)=tmparray(i,j,k) endif end do end do end do endif end do #endif fsum=0. fmin=1.e40 fmax=-1.e40 do k=1,ld do j=1,n2 do i=1,n1 fsum=fsum+temp(i,j,k) fval=temp(i,j,k) fmin=min(fmin,fval) fmax=max(fmax,fval) end do end do end do fsum=fsum/float(n1*n2*ld) ierr = v5dwrite( IT, IV, temp ) if (ierr.ne.0) then print *,'WRITE ',varname,' FAILED ',ierr,fmin,fmax,fsum else print *,'WRITE ',varname,' SUCCES ',ierr,fmin,fmax,fsum endif return end subroutine v5dcollectk(datarr) c c This subroutine send data to PE0 to write them to the history file c include 'param.nml' include 'msg.inc' include 'param.v5d' #include "msg.lnk" #include "msg.lnp" ! common/blocktempv/ tmparray(np,mp,l) dimension tmparray(np,mp,ld) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) nmlp=np*mp*ld ilim=np jlim=mp do k=ld1,ld2 do j=1,jlim do i=1,ilim tmparray(i,j,k-ld1+1)=datarr(i,j,k) end do end do end do #if (PARALLEL == 2) call MPI_Recv(fsg,1,DC_TYPE,0,mype,MPI_COMM_EULAG,status,ierr) call MPI_Send(tmparray, nmlp, DC_TYPE, 0, 1000+mype, . MPI_COMM_EULAG, ierr) #endif return end #endif #endif C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine transform(f,ff,iflg) include 'param.nml' include 'msg.inc' parameter(n1=np,n2=mp,n3=l) dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . ff(1-ih:np+ih, 1-ih:mp+ih, l), . zrcp(1-ih:np+ih, 1-ih:mp+ih, l) dimension z(n3) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml1,yml1,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) data igros/1/ if(iflg.eq.100) then tlo=1.0E35 else if((iflg.eq.2).or.(iflg.eq.3).or.(iflg.eq.4))then ! u,v,w tlo=0. else if((iflg.eq.41).or.(iflg.eq.42).or.(iflg.eq.43))then ! ox,oy,oz tlo=0. else if((iflg.eq.5).or.(iflg.eq.6))then tlo=-999999.0000 else call continl(f,cmn,cmx,n1,n2,n3) tlo=cmn-(cmx-cmn)/255 endif do 12 k=1,l 12 z(k)=(k-1)*dz c if(igros.eq.0) then c do 1 i=1,np c do 1 j=1,mp c do 1 k=1,l c 1 zrcp(i,j,k)=z(k)*((z(l)-zs(i,j))/z(l))+zs(i,j) c do 13 j=1,mp c do 13 i=1,np c zzs=zs(i,j) c do 13 kk=1,l c zzr=z(kk) c if(zzr.lt.zzs) then c ff(i,j,kk)=tlo c else c kkk=kk c cmin= 1.e15 c do 14 k0=1,l c roznic=abs(zzr-zrcp(i,j,k0)) c cmin=amin1(cmin,roznic) c 14 if(cmin.eq.roznic) kkk=k0 c ff(i,j,kk)=f(i,j,kkk) c endif c 13 continue c endif if(igros.eq.1) then do j=1,mp do i=1,np zzs=zs(i,j) do kk=1,l zzr=z(kk) if(zzr.ge.zzs) then kkk=int((zzr-zs(i,j))*(l-1)/((l-1)*dz-zs(i,j))+0.5)+1 ff(i,j,kk)=f(i,j,kkk) else ff(i,j,kk)=tlo endif enddo enddo enddo endif itest=1 if(itest.eq.1) then fmin= 1.e36 fmax=-1.e36 do j=1,mp do i=1,np do k=1,l fmin=min(fmin, f(i,j,k)) fmax=max(fmax, f(i,j,k)) enddo enddo enddo fmin=globmin(fmin,1,1,1,1,1,1,1,1,1,1,1,1) fmax=globmax(fmax,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print *,'fminmax2:',fmin,fmax,fsum endif itest=1 if(itest.eq.1) then fmin= 1.e36 fmax=-1.e36 fsum=0. rmin= 1.e36 rmax=-1.e36 rsum=0. do j=1,mp do i=1,np do k=1,l fmin=min(fmin, f(i,j,k)) fmax=max(fmax, f(i,j,k)) fsum=fsum + f(i,j,k) rmin=min(rmin,ff(i,j,k)) rmax=max(rmax,min(1.0E35,ff(i,j,k))) rsum=rsum + ff(i,j,k) enddo enddo enddo fmin=globmin(fmin,1,1,1,1,1,1,1,1,1,1,1,1) fmax=globmax(fmax,1,1,1,1,1,1,1,1,1,1,1,1) fsum=globsum(fsum,1,1,1,1,1,1,1,1,1,1,1,1) rmin=globmin(rmin,1,1,1,1,1,1,1,1,1,1,1,1) rmax=globmax(rmax,1,1,1,1,1,1,1,1,1,1,1,1) rsum=globsum(rsum,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print *,'fminmaxf:',fmin,fmax,fsum if(mype.eq.0) print *,'fminmaxr:',rmin,rmax,rsum endif return end subroutine continl(f,cmn,cmx,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) cmx=-1.e10 cmn= 1.e10 do k=1,n3 do j=1,n2 do i=1,n1 cmx=amax1(cmx,f(i,j,k)) cmn=amin1(cmn,f(i,j,k)) enddo enddo enddo return end #if (GKS == 1) c include '/home/rd/naw/Model/conrec_UB.gks' c include '/home/rd/naw/Model/velvct_UB.gks' include 'conrec.gks' #include "velvct.gks" #if (SPCTPL == 1) cinclude(/users/andii/model/graphics/cfftpack.f) include 'cfftpack.f' #endif #if (COLORPL == 1) cinclude(/users/andii/model/graphics/colorpl.gks) include 'colorpl.gks' #endif #endif '\eof' ############################################################################## # # 'temp.def' - contain definitions for temp aarray in I/O routines # ############################################################################## echo CREATE_TEMPR.DEF cat > tempr.def << '\eof' #if (IORFLAG == 0) #if (IORTAPE == 3) /* force to read from double precision archive */ real*8 temp(n,m,l) real*8 fval #endif #if (IORTAPE == 2) /* force to read from single precision archive */ real*4 temp(n,m,l) real*4 fval #endif #if (IORTAPE == 1) dimension temp(n,m,l) real fval #endif #endif /* smolar correction */ #if (IORFLAG == 1) #if (IORTAPE == 3) /* force to read from double precision archive */ real*8 temp(npa,mpa,l) real*8 fval #endif #if (IORTAPE == 2) /* force to read from single precision archive */ real*4 temp(npa,mpa,l) real*4 fval #endif #if (IORTAPE == 1) dimension temp(npa,mpa,l) real fval #endif #endif /* smolar correction */ '\eof' echo CREATE_TEMPW.DEF cat > tempw.def << '\eof' #if (IOWFLAG == 0) #if (IOWTAPE == 3) /* force to write to double precision archive */ real*8 temp(n,m,l) real*8 fval #endif #if (IOWTAPE == 2) /* force to write to single precision archive */ real*4 temp(n,m,l) real*4 fval #endif #if (IOWTAPE == 1) dimension temp(n,m,l) real fval #endif #endif #if (IOWFLAG == 1) #if (IOWTAPE == 3) /* force to write to double precision archive */ real*8 temp(npa,mpa,l) real*8 fval #endif #if (IOWTAPE == 2) /* force to write to single precision archive */ real*4 temp(npa,mpa,l) real*4 fval #endif nn = 2 mm = 1 ll = 2 #if (IOWTAPE == 1) dimension temp(npa,mpa,l) real fval #endif #endif '\eof' ############################################################################## # # 'msg.lnk' - contain include files for MMP code # ############################################################################## echo CREATE_MSG.LNK 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 || PLE > 0 || IBM > 0 || CPQ > 0 || LNX >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) * comm_type : indicate what MPI Comm. routine are used, * (either collective or point to point). * parameters used in transpose algorithms * commslice_y: the transpose between phase 1 and phase 2 involves * all-to-all comm. among npy processors * commslice_x: the transpose between phase 2 and phase 3 involves * all-to-all comm. among npx processors * DC_TYPE : the data type of the data in communication (4 or 8 bytes) integer DC_TYPE common/t23comm/ DC_TYPE integer my_row,my_col,m_south_pole,m_north_pole common/x_slice/ my_row common/y_slice/ my_col common/s_pole/ m_south_pole common/n_pole/ m_north_pole integer stats,statr integer statuss(MPI_STATUS_SIZE) c GM:Define some parameters to be used in the bridge segment parameter (nprocx_frn_max=100) integer MPI_COMM_EULAG,nprocx_frn,xind_rng,peer_frn,nprocy_frn ! integer :: tag_frn = 1734 integer :: tag_frn = 0 common/mpigm/ MPI_COMM_EULAG,tag_frn,nprocx_frn,nprocy_frn, . peer_frn,xind_rng(0:nprocx_frn_max-1, 2) #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) include '/usr/include/mpp/shmem.fh' #else include 'mpp/shmem.fh' #endif #endif '\eof' echo CREATE_MSG.LNP 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' echo CREATE_CONREC.GKS 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 CIBM8 COMMON/INTPR/FPART,TENSN,SMALL,ADDLR,ADDTB,MLLINE, CIBM81 ICLOSE,IPAU,NP1,L1 COMMON /SMOLAB/ ISWIT,ILABS, IOFFMS COMMON /SMOSPV/ SPVAS,JSWIT, IOFFPS COMMON /CONRE1/ SPVAL ,IOFFP 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/ SPVAL ,IOFFP 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/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE1/ SPVAL ,IOFFP COMMON /CONRE3/ IXBITS ,IYBITS LOGICAL IPEN ,IPENO C COMMON/TOPOG/ CTP(2000),HTP(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 COLD C FY(X,Y)=Y+ITOP*((CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))- C 1CTP(IFIX(X+1.))))*(Z0-Y)) FY(X,Y)=(1-ITOP)*Y + ITOP*(Y*( HTP(IFIX(X)) 1 +(IFIX(X)-X)*(HTP(IFIX(X))-HTP(IFIX(X+1.)))) 1+(CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))-CTP(IFIX(X+1.))))*(Z0-Y)) 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/ SPVAL, IOFFP 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/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 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/ SPVAL ,IOFFP COMMON /CONRE2/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 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 COLD 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),HTP(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 COLD C FY(XX,YY)=YY+ITOP*((CTP(IFIX(XX))+(IFIX(XX)-XX)*(CTP(IFIX(XX))- C 1CTP(IFIX(XX+1.))))*(Z0-YY)) FY(X,Y)=(1-ITOP)*Y + ITOP*(Y*( HTP(IFIX(X)) 1 +(IFIX(X)-X)*(HTP(IFIX(X))-HTP(IFIX(X+1.)))) 1+(CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))-CTP(IFIX(X+1.))))*(Z0-Y)) 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 LITARFL=1 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 IF(IVRT.EQ.0) THEN write (label,904) ha 904 FORMAT(F7.2,5H M/S) ENDIF IF(IVRT.EQ.1) THEN write (label,9041) ha 9041 FORMAT(E10.3,4H vrt) ENDIF C C TURN OFF CLIPPING SO ARROW CAN BE DRAWN C CALL GQCLIP(IER,ICLP,IAR) CALL GSCLIP(0) IF(LITARFL.EQ.1) THEN #if (COLORPL == 1) CALL DRWVEC (24768,3608,24768+LEN,3608,LABEL,14) #else CALL DRWVEC (28768,384,28768+LEN,384,LABEL,14) #endif ENDIF 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*14 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 CIBM8 common /str03/ arowl,uvmsg,displ,dispc,cstop, CIBM81 inita,initb,iterp,iterc,igflg,imsg,icyc 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 CIBM8 common /str03/ arowl,uvmsg,displ,dispc,cstop, CIBM81 inita,initb,iterp,iterc,igflg,imsg,icyc COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP COMMON /STR04/ XCHK(NCHK) ,YCHK(NCHK) , UXSML, NUMCHK COMMON/TOPOG/ CTP(2000),HTP(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 COLD C FY(XX,YY)=YY+ITOP*((CTP(IFIX(XX))+(IFIX(XX)-XX)*(CTP(IFIX(XX))- C 1CTP(IFIX(XX+1.))))*(Z0-YY)) FY(X,Y)=(1-ITOP)*Y + ITOP*(Y*( HTP(IFIX(X)) 1 +(IFIX(X)-X)*(HTP(IFIX(X))-HTP(IFIX(X+1.)))) 1+(CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))-CTP(IFIX(X+1.))))*(Z0-Y)) 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 CIBM8 common /str03/ arowl,uvmsg,displ,dispc,cstop, CIBM81 inita,initb,iterp,iterc,igflg,imsg,icyc 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-INFORMATION LABEL SIZE',cils) ccwm=1. call cpsetr('CWM-CHARACTER WIDTH MULTIPLER',ccwm) C 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),htp(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=(1-itop)*yinp + itop*(yinp*( htp(ifix(xinp)) 1 +(ifix(xinp)-xinp)*(htp(ifix(xinp))-htp(ifix(xinp+1.)))) 1 +(ctp(ifix(xinp))+(ifix(xinp)-xinp)*(ctp(ifix(xinp)) 1 -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 '\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,IERR) 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 30 #define MAXTIMES 200 #ifdef MCIDAS_SIDECAR #define MAXROWS 500 #define MAXCOLUMNS 500 #else #define MAXROWS 500 #define MAXCOLUMNS 500 #endif #define MAXLEVELS 200 /************************************************************************/ /*** ***/ /*** 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' echo "SCRIPTS CREATED IN THE WORKING DIRECTORY" goto DEFAULT_SET_DONE DEFAULT_SETUP: ############################################################################# #### #### ## 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 # # # ############################################################################# 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 1 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 1 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 1 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 1 endif if ($NCARG == 0) then setenv PLOTR 0 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 1 endif if ($PLOTR == 0) then setenv SPCTR 0 endif goto RETURN_FROM_DEFAULT DEFAULT_SET_DONE: goto SET_PRECOMPILATOR_DONE SET_PRECOMPILATOR: ############################################################################# # # # 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 X 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 == 0) then cat >> src.F << '\eof' #define ANALIZE 0 '\eof' endif if ($ANALIZ == 1) then cat >> src.F << '\eof' #define ANALIZE 1 '\eof' endif ########################## ### GRAPHICS SECTION ### ########################## if ($MESSG == ONE) then if ($MACHINE == T3D || $MACHINE == T3E) then cat >> src.F << '\eof' #define GKS 0 '\eof' else 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 '\eof' endif ######################### if ($VIS5D == 1) then cat >> src.F << '\eof' #define V5D 1 '\eof' else cat >> src.F << '\eof' #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 ######################### if ($ENERGY == 1) then cat >> src.F << '\eof' #define ENERGY 1 '\eof' else cat >> src.F << '\eof' #define ENERGY 0 '\eof' endif ######################### if ($ENERGY2 == 1) then cat >> src.F << '\eof' #define ENERGY2 1 '\eof' else cat >> src.F << '\eof' #define ENERGY2 0 '\eof' endif ######################### ### MACHINE SETUP ### ######################### if ($MACHINE == T3D) then cat >> src.F << '\eof' #define CRAYT3D 1 '\eof' else cat >> src.F << '\eof' #define CRAYT3D 0 '\eof' endif ######################### if ($MACHINE == PVP) then cat >> src.F << '\eof' #define CRAYPVP 1 '\eof' else cat >> src.F << '\eof' #define CRAYPVP 0 '\eof' endif ######################### if ($MACHINE == T3E) then cat >> src.F << '\eof' #define CRAYT3E 1 '\eof' else cat >> src.F << '\eof' #define CRAYT3E 0 '\eof' endif ######################### if ($MACHINE == O2K) then 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 else cat >> src.F << '\eof' #define SGI_O2K 0 '\eof' endif ######################### if ($MACHINE == HP) then 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 else cat >> src.F << '\eof' #define HP 0 '\eof' endif ######################### if ($MACHINE == WRK || $MACHINE == NEC) then cat >> src.F << '\eof' #define WORKS 1 '\eof' else cat >> src.F << '\eof' #define WORKS 0 '\eof' endif ######################### if ($MACHINE == VP7) then 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 else cat >> src.F << '\eof' #define FUJI_VPP 0 '\eof' endif ######################### if ($MACHINE == IBM || $MACHINE == BGL) then 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 if($SIGNAL_TRAP == 1) then cat >> src.F << '\eof' #define SIGNAL_TRAP 1 '\eof' endif else cat >> src.F << '\eof' #define IBM 0 '\eof' endif ######################### if ($MACHINE == LNX) then if ($WORD == 4) then cat >> src.F << '\eof' #define LNX 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define LNX 2 '\eof' endif if($SIGNAL_TRAP == 1) then cat >> src.F << '\eof' #define SIGNAL_TRAP 1 '\eof' endif else cat >> src.F << '\eof' #define LNX 0 '\eof' endif ######################## if ($MACHINE == CPQ) then if ($WORD == 4) then cat >> src.F << '\eof' #define CPQ 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define CPQ 2 '\eof' endif else cat >> src.F << '\eof' #define CPQ 0 '\eof' endif ######################### if ($MACHINE == PLE) then if ($WORD == 4) then cat >> src.F << '\eof' #define PLE 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define PLE 2 '\eof' endif else cat >> src.F << '\eof' #define PLE 0 '\eof' endif ######################### cat src.F goto RETURN_SET_PRECOMPILATOR SET_PRECOMPILATOR_DONE: ############################################################################# #### #### #### C O M P I L E V I S 5 D C O D E #### #### #### ############################################################################# date rm -f a.out rm -f output.t3d ######################### echo NOW_COMPILE_v5d43.c ######################### if ($VIS5D == 1) then if ($MACHINE == NEC) then echo 'cc -c -hfloat0 -DLITTLE -DUNDERSCORE -I "./" v5d43.c -o v5d43.o' # cc -c -hfloat0 -DUNDERSCORE -I "./" v5d43.c -o v5d43.o cc -c -hfloat0 -DUNDERSCORE -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o endif if ($MACHINE == PVP) then echo 'cc -c -g -h msglevel_3 -D _CRAY -I "./" v5d43.c -o v5d43.o' cc -c -g -h msglevel_3 -D _CRAY -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o endif if ($MACHINE == WRK) then if ($WORD == 4) then # If DEC or Linux (Little-endian), add -DLITTLE to CFLAGS # If AIX, remove the -DUNDERSCORE echo 'cc -c -g -DUNDERSCORE v5d43.c -o v5d43.o' cc -c -g -DUNDERSCORE v5d43.c -o v5d43.o setenv OBJECTS v5d43.o else echo 'VIS5D with double prec. not implemented yet' setenv OBJECTS endif endif if ($MACHINE == CPQ) then if ($WORD == 4) then # If DEC or Linux (Little-endian), add -DLITTLE to CFLAGS # If AIX, remove the -DUNDERSCORE echo 'cc -c -g -I "./" v5d43.c -o v5d43.o' cc -c -g -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o else echo 'VIS5D with double prec. not implemented yet' setenv OBJECTS endif endif if ($MACHINE == IBM || $MACHINE == BGL) then echo 'cc -c -g -I "./" v5d43.c -o v5d43.o' cc -c -g -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o endif if ($MACHINE == O2K) then if ($WORD == 4) then echo 'cc -mips4 -64 -c -g -I "./" v5d43.c -o v5d43.o' cc -mips4 -64 -c -g -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o else echo 'VIS5D dont work with double prec. due to cc problem' setenv OBJECTS endif endif if ($MACHINE == HP) then if ($WORD == 4) then echo 'cc -c -g -I "./" v5d43.c -o v5d43.o' cc -c -g -I "./" v5d43.c -o v5d43.o setenv OBJECTS v5d43.o else echo 'VIS5D dont work with double prec. - cc compiler problem' setenv OBJECTS . endif endif else if ($MACHINE == HP) then setenv OBJECTS "" else setenv OBJECTS endif endif ############################################################################# #### #### #### C O M P I L E A N D L I N K P R G R A M #### #### #### ############################################################################# echo NOW_COMPILE_src.F ######################### if ($MACHINE == NEC) then echo NOW_COMPILE_src.F_NEC echo RUN_COMPILE_NEC if ($MESSG == MPI) then # ccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O 1 -Wl"-f indef" src.F -lmpi' f90 src.F -lmpi # ccccccccccccccccccccccccccccccccccccccccc else if ($NCPUS == 1) then # ccccccccccccccccccccccccccccccccccccccccc echo 'f90 -C hopt -float2 -Wl"-f indef" src.F OBJECTS' f90 -C hopt src.F $OBJECTS # f90 -Wf"-w double16" src.F # ccccccccccccccccccccccccccccccccccccccccc else # ccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O task2 -c -Wl"-f indef" src.F' f90 -O task2 -c -Wl"-f indef" src.F # ccccccccccccccccccccccccccccccccccccccccc endif endif endif ######################### if ($MACHINE == PVP) then echo NOW_COMPILE_src.F_PVP ja echo RUN_COMPILE_PVP if ($MESSG == MPI) then # cccccccccccccccccccccccccccccccccccc echo 'f90 -Wl"-f indef" src.F -lmpi' f90 -Wl"-f indef" src.F -lmpi # cccccccccccccccccccccccccccccccccccc else if ($NCARG == 1) then echo COMPILE_WITH_NCAR_GRAPHICS if ($NCPUS == 1) then # cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O2 -c -Wl"-f indef" src.F' f90 -O2 -c -Wl"-f indef" src.F segldr src.o $OBJECTS -f indef -L /lib,/usr/lib,/usr/local/lib \ -lncarm,ncaro,ncarg,ncarg_gks,ncarg_c,ncarg_loc,X11 # cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else # cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O task2 -c -Wl"-f indef" src.F' f90 -O task2 -c -Wl"-f indef" src.F segldr src.o $OBJECTS -f indef -L /lib,/usr/lib,/usr/local/lib \ -lncarm,ncaro,ncarg,ncarg_gks,ncarg_c,ncarg_loc,X11 # cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif else echo COMPILE_WITHOUT_NCAR_GRAPHICS if ($NCPUS == 1) then echo COMPILE_NCPUS_1 if ($PERFM == 1) then # ccccccccccccccccccccccccccccccccccccccccc echo 'PERFORMANCE TOOL - JUMPVIEW' echo 'f90 -G1 -ltrace -Wl"-f indef" src.F' f90 -G1 -ltrace -Wl"-f indef" src.F # ccccccccccccccccccccccccccccccccccccccccc else # ccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O2 -Wl"-f indef" src.F' f90 -O2 -Wl"-f indef" src.F $OBJECTS #echo 'cf77 -Wf"-m 3 -e i" src.F' # cf77 -Wf"-m 3 -e i" src.F # ccccccccccccccccccccccccccccccccccccccccc endif else # ccccccccccccccccccccccccccccccccccccccccc echo COMPILE_NCPUS_$NCPUS echo 'f90 -O task2 -Wl"-f indef" src.F' f90 -O task2 -Wl"-f indef" src.F $OBJECTS #echo 'cf77 -Zp -Wf"-m 3 -e i" src.F' # cf77 -Zp -Wf"-m 3 -e i" src.F # ccccccccccccccccccccccccccccccccccccccccc endif endif endif ja -st endif #ls -la ######################### if ($MACHINE == T3D) then echo NOW_COMPILE_src.F_T3D ja echo RUN_COMPILE_T3D # APPRENTICE OPTIONS -eA -lapp if ($PERFM == 1) then echo 'PERFORMANCE TOOL - APPRENTICE' setenv APPRENTICE "-eA -lapp" else setenv APPRENTICE "" endif if ($MESSG == MPI) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O 1 -X $NPE -Wl"-f indef" src.F \' echo '-L/usr/local/MPI/t3d/lib/cray_t3d/t3d -lmpi' f90 -O 1 -X $NPE -Wl"-f indef" src.F \ -L/usr/local/MPI/t3d/lib/cray_t3d/t3d -lmpi $APPRENTICE # cccccccccccccccccccccccccccccccccccccccccccccccccc else # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O 1 -X $NPE -Wl"-f indef" src.F' f90 -O 1 -X $NPE -Wl"-f indef" src.F $APPRENTICE # cccccccccccccccccccccccccccccccccccccccccccccccccc endif ja -st endif ######################### if ($MACHINE == T3E) then echo NOW_COMPILE_src.F_T3E ja echo RUN_COMPILE_T3E if ($PERFM == 1) then echo 'PERFORMANCE TOOL - APPRENTICE' setenv APPRENTICE "-eA -lapp" else setenv APPRENTICE "" endif if ($MESSG == MPI) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O 1 -X $NPE -Wl"-D preset=-inf" src.F -lmpi' f90 -O 1 -X $NPE -Wl"-D preset=-inf" src.F -lmpi $APPRENTICE # cccccccccccccccccccccccccccccccccccccccccccccccccc else # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -O 1 -X $NPE -Wl"-D preset=-inf" src.F' f90 -O 1 -X $NPE -Wl"-D preset=-inf" src.F $APPRENTICE # cccccccccccccccccccccccccccccccccccccccccccccccccc endif ja -st endif ######################### if ($MACHINE == O2K) then echo NOW_COMPILE_src.F_O2K echo RUN_COMPILE_SGI_ORIGIN_2000 if ($MESSG == MPI) then if ($WORD == 4) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -r4 -mips4 -64 -O3 src.F -lmpi' f90 -r4 -mips4 -64 -O3 src.F \ -I/usr/include -Wl,-L/usr/local/lib64/r4i4/,-L/usr/lib64 \ -lmss -lmpi # cccccccccccccccccccccccccccccccccccccccccccccccccc endif if ($WORD == 8) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -r8 -mips4 -64 -O3 src.F -lmpi' f90 -r8 -mips4 -64 -O3 src.F \ -I/usr/include -Wl,-L/usr/local/lib64/r8i4/,-L/usr/lib64 \ -lmss -lncaru -lmpi # cccccccccccccccccccccccccccccccccccccccccccccccccc endif endif if ($MESSG == SCH) then setenv PVM_ROOT /usr/array/PVM if ($WORD == 4) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -r4 -mips4 -64 -O1 src.F -lsma WORD 4' f90 -r4 -mips4 -64 -O1 src.F -OPT:reorg_common=OFF \ -I/usr/include -I/usr/include/mpp \ -Wl,-L/usr/local/lib64/r4i4,-L/usr/lib64/mips4 -lsma # -I/usr/array/PVM/include \ # -Wl,-L/usr/local/lib64/r4i4,-L/usr/lib64/mips4,-L/usr/array/PVM/lib/SGIMP64 \ # -lsma -lpvm -lpvm3 # cccccccccccccccccccccccccccccccccccccccccccccccccc endif if ($WORD == 8) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -r8 -mips4 -O3 -64 src.F -lsma' f90 -r8 -mips4 -O3 -64 src.F -OPT:reorg_common=OFF \ -I/usr/include -I/usr/include/mpp \ -Wl,-L/usr/local/lib64/r8i4,-L/usr/lib64/mips4 -lsma -l ncaru # cccccccccccccccccccccccccccccccccccccccccccccccccc endif endif if ($MESSG == ONE) then if ($NCARG == 1) then #COMPILE WITH NCAR_GRAPHICS if ($WORD == 4) then setenv NCARG_LIB /usr/local/lib64/r4i4 if ($NCPUS == 1) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -keep -r4 -mips4 -64 -avoid_gp_overflow -O2 src.F $OBJECTS' F90 -r4 -mips4 -64 -avoid_gp_overflow -O2 src.F $OBJECTS \ -Wl,-L/usr/local/lib64/r4i4/,-L/usr/lib64 \ -lmss -lncarg -lncarg_gks -lncarg_c -lX11 -lm # cccccccccccccccccccccccccccccccccccccccccccccccccc else # cccccccccccccccccccccccccccccccccccccccccccccccccc setenv MP_SET_NUMTHREADS $NCPUS echo COMPILE_NCPUS_$MP_SET_NUMTHREADS echo 'f90 -r4 -mips4 -64 -avoid_gp_overflow -O2 -pfa src.F $OBJECTS' f90 -r4 -mips4 -64 -avoid_gp_overflow -O2 -pfa src.F $OBJECTS \ -Wl,-L/usr/local/lib64/r4i4/,-L/usr/lib64 \ -lmss -lncarg -lncarg_gks -lncarg_c -lX11 -lm # cccccccccccccccccccccccccccccccccccccccccccccccccc endif endif if ($WORD == 8) then echo '!!! NCAR Graphics for 8 byte long folating piont not available yet !!!' setenv NCARG_LIB /usr/local/lib64/r8i4 if ($NCPUS == 1) then # cccccccccccccccccccccccccccccccccccccccccccccccccc echo 'f90 -r8 -mips4 -64 -avoid_gp_overflow -O3 src.F' f90 -r8 -mips4 -64 -avoid_gp_overflow -O3 src.F \ -Wl,-L/usr/local/lib64/r8i4/,-L/usr/lib64 \ -lmss -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm # cccccccccccccccccccccccccccccccccccccccccccccccccc else # cccccccccccccccccccccccccccccccccccccccccccccccccc setenv MP_SET_NUMTHREADS $NCPUS echo COMPILE_NCPUS_$MP_SET_NUMTHREADS echo 'f90 -r8 -mips4 -64 -avoid_gp_overflow -O3 -pfa src.F' f90 -r8 -mips4 -64 -avoid_gp_overflow -O3 -pfa src.F \ -Wl,-L/usr/local/lib64/r8i4/,-L/usr/lib64 \ -lmss -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm # cccccccccccccccccccccccccccccccccccccccccccccccccc endif endif else #COMPILE WITHOUT NCAR_GRAPHICS if ($WORD == 4) then if ($NCPUS == 1) then echo COMPILE_NCPUS_1 echo 'f90 -r4 -mips4 -64 -O3 src.F -Wl,-L... -lmss -lncaru -lm' f90 -r4 -mips4 -64 -O3 src.F $OBJECTS \ -Wl,-L/usr/local/lib64/r4i4/,-L/usr/lib64 -lmss -lncaru -lm else setenv MP_SET_NUMTHREADS $NCPUS echo COMPILE_NCPUS_$MP_SET_NUMTHREADS echo 'f90 -r4 -mips4 -64 -O3 -pfa src.F -Wl,-L... -lmss -lncaru -lm' f90 -r4 -mips4 -64 -O3 -pfa src.F $OBJECTS \ -Wl,-L/usr/local/lib64/r4i4/,-L/usr/lib64 -lmss -lncaru -lm endif endif if ($WORD == 8) then if ($NCPUS == 1) then echo COMPILE_NCPUS_1 echo 'f90 -r8 -mips4 -64 -O3 src.F -Wl,-L... -lmss -lncaru -lm' f90 -r8 -mips4 -64 -O3 src.F \ -Wl,-L/usr/local/lib64/r8i4/,-L/usr/lib/lib64 -lmss -lncaru -lm else setenv MP_SET_NUMTHREADS $NCPUS echo COMPILE_NCPUS_$MP_SET_NUMTHREADS echo 'f90 -r8 -mips4 -64 -O3 -pfa src.F -Wl,-L... -lmss -lncaru -lm' f90 -r8 -mips4 -64 -O3 -pfa src.F \ -Wl,-L/usr/local/lib64/r8i4/,-L/usr/lib/lib64 -lmss -lncaru -lm endif endif #END COMPILE WITHOUT NCAR_GRAPHICS endif endif endif ######################### if ($MACHINE == HP) then echo NOW_COMPILE_src.F_HP echo RUN_COMPILE_HP # PERFORMANCE OPTION +pa if ($PERFM == 1) then echo 'PERFORMANCE TOOL' setenv PERFORMANCE "+pa" else setenv PERFORMANCE "" endif if ($MESSG == MPI) then if ($WORD == 8) then echo 'f77 +O2 +U77 +autodblpad -lmpi' f77 +O1 +U77 +autodblpad src.F -I/opt/mpi/include \ -Wl,-L/usr/local/lib,-L/opt/mpi/lib/pa1.1 \ -lncaru -lpmpi -lmpi -lm /usr/lib/libail.sl -lcnx_syscall $PERFORMANCE endif if ($WORD == 4) then echo 'f77 +O2 +U77 -lmpi' f77 +O1 +U77 src.F -I/opt/mpi/include \ -Wl,-L/usr/local/lib,-L/opt/mpi/lib/pa1.1 \ -lncaru -lpmpi -lmpi -lm /usr/lib/libail.sl -lcnx_syscall $PERFORMANCE endif # FFLAGS = +O3 +Ofastaccess +Onoloop_transform +Oinfo +Onoinline +Oinline=mapder,vordiv,grad2s,hydro,uvcoord,vertadv,vertvel,kcross,dotp2,vertadv,compute_p_over_rho else if ($NCARG == 1) then #COMPILE WITH NCAR_GRAPHICS if ($WORD == 4) then if ($NCPUS == 1) then echo 'f77 +O1 +U77 src.F -lncarg ' f77 +O1 +U77 src.F \ -Wl,-L/usr/local/sncarg/lib,-L/usr/lib/Motif1.2,-L/usr/lib/X11R5,-L/usr/local/lib \ -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm else setenv MP_NUMBER_OF_THREADS $NCPUS echo 'f77 +O3 +U77 +Oparallel src.F -lncarg ' f77 +O3 +U77 +Oparallel src.F $OBJECTS \ -Wl,-L/usr/local/sncarg/lib,-L/usr/lib/Motif1.2,-L/usr/lib/X11R5,-L/usr/local/lib \ -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm endif endif if ($WORD == 8) then if ($NCPUS == 1) then echo 'f77 +O1 +U77 +autodblpad src.F -lncarg' f77 +O1 +U77 +autodblpad src.F \ -Wl,-L/usr/local/lib,-L/usr/lib/Motif1.2,-L/usr/lib/X11R5,-L/usr/local/lib \ -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm else setenv MP_NUMBER_OF_THREADS $NCPUS echo 'f77 +O3 +U77 +autodblpad +Oparallel src.F -lncarg' f77 +O3 +U77 +autodblpad +Oparallel src.F \ -Wl,-L/usr/local/lib,-L/usr/lib/Motif1.2,-L/usr/lib/X11R5,-L/usr/local/lib \ -lncaru -lncarg -lncarg_gks -lncarg_c -lX11 -lm endif endif else #COMPILE WITHOUT NCAR_GRAPHICS if ($WORD == 4) then if ($NCPUS == 1) then echo COMPILE_NCPUS_1 echo 'f77 +O1 +U77 src.F -Wl,-L/usr/local/lib -lncaru -lm' f77 +O1 +U77 src.F -Wl,-L/usr/local/lib -lncaru -lm $PERFORMANCE else setenv MP_NUMBER_OF_THREADS $NCPUS echo COMPILE_NCPUS_$MP_NUMBER_OF_THREADS echo 'f77 +O3 +U77 +Oparallel src.F -Wl,-L/usr/local/lib -lncaru -lm' f77 +O3 +U77 +Oparallel src.F $OBJECTS -Wl,-L/usr/local/lib \ -lncaru -lm $PERFORMANCE endif endif if ($WORD == 8) then if ($NCPUS == 1) then echo COMPILE_NCPUS_1 echo 'f77 +O2 +U77 +autodblpad src.F -Wl,-L/usr/local/lib -lncaru' -lm f77 +O2 +U77 +autodblpad src.F -Wl,-L/usr/local/lib -lncaru -lm $PERFORMANCE else setenv MP_NUMBER_OF_THREADS $NCPUS echo COMPILE_NCPUS_$MP_NUMBER_OF_THREADS echo 'f77 +O3 +U77 +Oparallel +autodblpad src.F -Wl,-L... -lncaru' -lm f77 +O3 +U77 +Oparallel +autodblpad src.F -Wl,-L/usr/local/lib \ -lncaru -lm $PERFORMANCE endif endif #END COMPILE WITHOUT NCAR_GRAPHICS endif endif endif ############################################################################# #### #### #### F U J I T S U V P P - 7 0 0 S C R I P T S #### #### #### ############################################################################# if ($MACHINE == VP7) then ########################## echo ####################### echo RUN_COMPILE_Fuji_VPP700 echo ####################### use sgi_vpp if ($WORD == 8) then setenv DOUBLE '-Ad ' else setenv DOUBLE '' endif if ($MESSG == MPI) then setenv FOP '-Ss -c -AoQm -Oe,-e,-u,-p -Pstao -Wv,-m3 -X9 -Fixed -v9' setenv LOP '-Zcompile.list -Wl,P,J -I/home/na/nas/MPI/' echo 'frtpx' $DOUBLE $FOP $LOP frtpx src.F $DOUBLE $FOP $LOP else if ($NCPUS == 1) then setenv FOP '-c -AoQm -Oe,-e,-u,-p -Pstao -Wv,-m3 -X9 -Fixed -v9' setenv LOP '-Zcompile.list' echo 'frtpx' $DOUBLE $FOP $LOP frtpx src.F $DOUBLE $FOP $LOP else echo 'Multiprocessor compiler options not implemented on Fuji VPP 700' endif cat compile.list|egrep 'diagnostic mess|i-w|i-s'|grep -v 'mpif.h'||true cat compile.list|grep 'i-s' || true endif ls -la echo ############################ echo RUN_COMPILE_Fuji_VPP700-DONE echo ############################ echo ######################### echo RUN_COMPOSING_Fuji_VPP700 echo ######################### if(-f src.o) then ########################################################################### #CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #------------------------------- echo 'PREPARE object for VPP700' #------------------------------- rm -f ./$JNAME.o rm -f ./$JNAME.F mv src.o $JNAME.o mv src.F $JNAME.F chmod a+r $JNAME.o ls -la $JNAME.o #------------------------------- echo 'OBJECT for VPP700 - READY' #------------------------------- rm -f ./analysis.F rm -f ./analysis.o rm -f ./analysis rm -f ./analysis.comp rm -f ./analysis.run rm -f ./run_vpp rm -f ./jtape rm -f ./itape rm -f ./ktape if ($NCARG_VP7 == 1) then #CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ########################################################################### #CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #-------------------------------- echo 'DEFINE NEW ANALYSING CODE' #-------------------------------- cat > analysis.F << '\eof' #define WORKS 1 #define FUJI_VPP 0 #define PARALLEL 0 #define GKS 1 '\eof' if ($WORD == 8) then cat >> analysis.F << '\eof' #define ANALIZE 2 '\eof' else cat >> analysis.F << '\eof' #define ANALIZE 1 '\eof' endif if ($COLOR_VP7 == 1) then cat >> analysis.F << '\eof' #define COLORPL 1 '\eof' else cat >> analysis.F << '\eof' #define COLORPL 0 '\eof' endif if ($PLOTR_VP7 == 1) then cat >> analysis.F << '\eof' #define PLOTPL 1 '\eof' else cat >> analysis.F << '\eof' #define PLOTPL 0 '\eof' endif if ($TURBL_VP7 == 1) then cat >> analysis.F << '\eof' #define TURBPL 1 '\eof' else cat >> analysis.F << '\eof' #define TURBPL 0 '\eof' endif if ($SPCTR_VP7 == 1) then cat >> analysis.F << '\eof' #define SPCTPL 1 '\eof' else cat >> analysis.F << '\eof' #define SPCTPL 0 '\eof' endif if ($VORTX_VP7 == 1) then cat >> analysis.F << '\eof' #define VORTPL 1 '\eof' else cat >> analysis.F << '\eof' #define VORTPL 1 '\eof' endif cat $JNAME.F| \ egrep -v '#define ANAL|#define GKS|#define PARA|#define FUJI_|#define WORK'| \ egrep -v '#define COLOR|#define PLOT|#define TURB|#define SPCT|#define VORT' \ >>analysis.F cat > msg.inc0 << '\eof' parameter (nprocx=1, nprocy=1) '\eof' cat msg.inc|egrep -v 'nprocx='>>msg.inc0 mv msg.inc0 msg.inc #-------------------------------------- echo 'DEFINE NEW ANALYSING CODE - DONE' ####################################### echo 'COMPILE ALALYSIS CODE ON belgan' #-------------------------------------- cat > analysis.comp0 << '\eof' #!/bin/csh f90 -w -o TMP_DIR/analysis TMP_DIR/analysis.F TMP_DIR/cfftpack.f \ -L/tmp/lib -lncarg -lncarg_gks -lncarg_c -lX11 '\eof' sed 's#TMP_DIR#'$TMPDIR'#g' analysis.comp0>analysis.comp rm -f ./analysis.comp0 chmod a+x analysis.comp rsh belgan $TMPDIR/analysis.comp #-------------------------------------------- echo 'COMPILE ALALYSIS CODE ON belgan - DONE' ############################################# if (-f analysis) then ############################## echo 'COMPOSE ALALYSIS SCRIPT' #----------------------------- chmod a+x analysis cat > analysis.run0 << '\eof' #!/bin/csh setenv NCARG_GKS_OUTPUT gmeta.JNAME setenv TMPDIR TMP_DIR if (! -d $TMPDIR) then mkdir -p -m 775 $TMPDIR endif cd $TMPDIR setenv cwd pwd echo 'WORK DIRECTORY: '$cwd echo 'GMETA OUT_NAME: '$NCARG_GKS_OUTPUT if (! -f itape) then ecp -o ec:/nas/model/JNAME jtape else mv itape jtape endif /bin/rm -f fort.10 ln -s jtape fort.10 ./analysis '\eof' sed -e 's/JNAME/'$JNAME'/g' -e 's#TMP_DIR#'$TMPDIR'#g' \ analysis.run0>analysis.run rm -f ./analysis.run0 chmod a+x analysis.run #------------------------------------ echo 'COMPOSE ALALYSIS SCRIPT - DONE' #------------------------------------ else ls -la #-------------------------------------------------- echo 'ANALYSIS CODE ERROR - NO analysis FILE FOUND' ################################################### endif endif ########################################################################### # N C A R G R A P H I C S - D O N E ########################################################################### if ($OLDTAPE != 0) then echo 'ecp -o ec:/nas/model/OLDTAPE OLDTAPE' ecp -o ec:/nas/model/$OLDTAPE $OLDTAPE endif if ($TOPOTAPE != 0) then rm -f fort.11 ktape ecp -o ec:/nas/model/$TOPOTAPE ktape ln -s ktape fort.11 endif cat > tape.job << '\eof' #QSUB -r JNAME.plot -s /bin/ksh -lP 1 -eo -q vpp700.normal -lt 1500 -lT 1500 -lM 64 cd VPP_DIR #CSC if [ -f itape ] ; then #CSC /tmp/mrfs/bin/cp itape /wsTMP_DIR/ #CSC fi '\eof' if ($NCARG_VP7 == 1) then cat >> tape.job << '\eof' rsh belgan TMP_DIR/analysis.run '\eof' endif cat >> tape.job << '\eof' #CSC if [ -f itape ] ; then #CSC ecp -o itape ec:/nas/model/JNAME #CSC fi '\eof' sed -e 's/JNAME/'$JNAME'/g' \ -e 's#VPP_DIR#'$VPPTMPDIR'#g'\ -e 's#TMP_DIR#'$TMPDIR'#g' \ -e 's/#CSC //g' \ tape.job >tape.job0 mv tape.job0 tape.job ########################################################################### echo 'DEFINE EXECUTING VPP700 SCRIPT' #------------------------------------ cat > run_vpp0 << '\eof' #QSUB -r JNAME -s /bin/ksh -lP NPS -eo -q VPPQ -lt VPPt -lT VPPT -lM VPPM set -aex TMPDIR=VPP_DIR FORT90L='-Wl,-e1' if [ ! -d $TMPDIR ] ; then mkdir -p -m 775 $TMPDIR || true fi cd $TMPDIR /bin/rm -f itape fort.9 ln -s itape fort.9 '\eof' if ($OLDTAPE != 0) then cat >> run_vpp0 << '\eof' /bin/rm -f jtape fort.10 ln -s jtape fort.10 cp /wsTMP_DIR/OLDTAPE jtape '\eof' endif if ($TOPOTAPE != 0) then cat >> run_vpp0 << '\eof' /bin/rm -f ktape fort.11 ln -s ktape fort.11 cp /wsTMP_DIR/ktape ktape '\eof' endif if ($MESSG == MPI) then cat >> run_vpp0 << '\eof' # ================================== echo RUN_COMPILING_Fuji_VPP700_PARALLEL # ================================== #frt -Ss -c JNAME.F -Wl,-P,-J,-m,-uMAIN__ -X9 $FORT_MPI #FORT_MPI='-L/usr/lang/mpi/lib -lmpi -lmp -lelf -lpx -I/usr/lang/mpi/include' FORT_MPI='-L/usr/lang/mpi/lib -lmpi -lmp -I/usr/lang/mpi/include' frt -o exe.JNAME /wsTMP_DIR/JNAME.o -Wl,-P,-J,-m,-uMAIN__ -X9 $FORT_MPI \ > load.map.JNAME size ./exe.JNAME # =================================== echo RUN_EXECUTABLE_Fuji_VPP700_PARALLEL # =================================== '\eof' else cat >> run_vpp0 << '\eof' # ============================== echo RUN_LINKING_Fuji_VPP700_VECTOR # ============================== frt -o exe.JNAME /wsTMP_DIR/JNAME.o -Wl,-J,-m,-uMAIN__ -X9 > load.map.JNAME #cat load.map.JNAME || true size ./exe.JNAME # ================================= echo RUN_EXECUTABLE_Fuji_VPP700_VECTOR # ================================= '\eof' endif if ($PERFM == 1) then cat >> run_vpp0 << '\eof' ###################################################### # VPP_STATS=n # n=0 - do nothing # n=1 - some basic timing info # n=2 - Use PEPA # n=4 - summary profiling without any detail # n=8 - normal profiling # n=16 - Detailed profiling to library level # n=32 - Additional info such as memory utilisation # n=64 - IO tracing # n=128 - Do not print out ascii profile ###################################################### VPP_STATS=11 export VPP_STATS '\eof' endif if ($MESSG == MPI) then cat >> run_vpp0 << '\eof' ./exe.JNAME # ======================================== echo RUN_EXECUTABLE_Fuji_VPP700_PARALLEL-DONE # ======================================== '\eof' else cat >> run_vpp0 << '\eof' ./exe.JNAME # ====================================== echo RUN_EXECUTABLE_Fuji_VPP700_VECTOR-DONE # ====================================== '\eof' endif cat >> run_vpp0 << '\eof' ls -la #CSC if [ -f itape ] ; then #CSC rsh belgan vppqsub TMP_DIR/tape.job #CSC fi '\eof' sed -e 's/JNAME/'$JNAME'/g' -e 's#VPP_DIR#'$VPPTMPDIR'#g'\ -e 's#TMP_DIR#'$TMPDIR'#g' -e 's/NPS/'$NPE'/g' \ -e 's/VPPQ/'$VPP_Q'/g' -e 's/VPPt/'$VPP_t'/g' \ -e 's/VPPT/'$VPP_T'/g' -e 's/VPPM/'$VPP_M'/g' \ -e 's/#CSC //g' \ run_vpp0>run_vpp1 if ($OLDTAPE != NONE) then sed -e 's/OLDTAPE/'$OLDTAPE'/g' -e 's/#TAP //g' \ run_vpp1>run_vpp2 mv run_vpp2 run_vpp1 endif rm -f ./run_vpp0 mv run_vpp1 run_vpp vppqsub run_vpp ls -la #------------------------------------------- echo 'DEFINE EXECUTING VPP700 SCRIPT - DONE' #------------------------------------------- #CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ########################################################################### endif echo ######################### echo RUN_COMPOSING_Fuji_VPP700 echo ######################### ################################ echo 'Fuji VPP700 SCRIPT DONE' ################################ endif endif ############################################################################# #### #### #### E N D o f F U J I T S U V P P - 7 0 0 S C R I P T S #### #### #### ############################################################################# ############################################################################# #### #### #### P L E I A D E S C L U S T E R S E T T I N G S #### #### #### ############################################################################# if ( $MACHINE == PLE ) then if( $machname == 'alphacrucis') then echo 'NOW_COMPILE_src.alphacrucis' set PGF90 = 'mpif90' if ( $WORD == 4 ) then echo "${PGF90} -c -O3 src.F -L${NETCDF_INCLUDE}" ${PGF90} -c -O3 src.F -I${NETCDF_INCLUDE} -I${MPI_INCLUDE} ${PGF90} src.o $OBJECTS -O3 -L$LD_LIBRARY_PATH -L${NETCDF_LIB} -lmpich else echo "${PGF90} -O3 -fpp -r8 -w -vec-report0 src.F -lmpi" ${PGF90} -O3 -fpp -r8 -w -vec-report0 src.F -lmpi # ${PGF90} -O3 -fpp -r8 src.F -w -lmpi endif endif ## END ALPHACRUCIS SETTINGS if( $machname == 'plato' || $machname == 'zwicky') then echo 'NOW_COMPILE_src.plato' set PGF90 = 'mpif90' set MPI_LIB='/opt/ompi/lib' set MPI_INCLUDE='/opt/ompi/include' if ( $WORD == 4 ) then echo "${PGF90} -c -O3 src.F -L${NETCDF_INCLUDE}" ${PGF90} -c -O3 src.F -I${NETCDF_INCLUDE} -I${MPI_INCLUDE} ${PGF90} src.o $OBJECTS -O3 -L$LD_LIBRARY_PATH -L${NETCDF_LIB} -lmpich else echo "${PGF90} -O3 -fpp -r8 src.F -w -I${MPI_INCLUDE} -L${MPI_LIB}" ${PGF90} -O3 -fpp -r8 src.F -w -lmpi endif endif ## END PLATO SETTINGS if( $machname == 'cineca' || $machname == 'parker' || $machname == 'galileo') then echo 'NOW_COMPILE_src.CINECA' set PGF90 = 'mpiifort' echo "${PGF90} -O3 -fpp -g -traceback -r8 src.F " ${PGF90} -O3 -fpp -g -traceback -r8 src.F -w # echo "${PGF90} -O3 -fpp -r8 -g -check all src.F " # ${PGF90} -O3 -fpp -r8 -g -check uninit src.F -w endif ## END PLATO SETTINGS if( $machname == 'pleiades') then echo 'NOW_COMPILE_src.pleaides' set PGF90 = 'ifort' if ( $WORD == 4 ) then echo "${PGF90} -c -O3 src.F -L${NETCDF_INCLUDE}" ${PGF90} -c -O3 src.F ${PNETCDF_LIB} -I${MPI_INCLUDE} ${PGF90} src.o $OBJECTS -O3 -L$LD_LIBRARY_PATH ${PNETCDF_LIB} -lnetcdf -lmpich -lnetcdff else echo "${PGF90} -O3 -r8 -xSSE4.1 -ip -w -vec-report0 src.F -lmpi" ${PGF90} -O3 -fpp -r8 -xSSE4.1 -ip -w -vec-report0 src.F -lmpi endif endif endif ## END PLE SETTINGS ############################################################################# #### if ($MACHINE == LNX) then if( $machname == 'bria') then echo 'compile bria' module load intel-compilers/12.0.4.191 module load MPI/Intel/mvapich2/1.6 # mpif90 -r8 -O3 -fp-model precise src.F -o a.out -mcmodel=medium -shared-intel # mpif90 -r8 -O3 -fp-model precise src.F -o a.out mpif90 -O3 -fp-model precise src.F -o a.out # mpif90 -O3 -fp-model precise src.F -o a.out # mpif90 -O3 -fp-model precise src.F -o a.out -I$PNETCDFINC -L$PNETCDFLIB -lpnetcdf endif if( $machname == 'cottos') then echo 'compile cottos' module load openmpi_intel64 mpif90 -r8 -O3 -fp-model precise src.F -o a.out # mpif90 -r8 -O0 -fp-model precise src.F -o a.out # mpif90 -O3 -fp-model precise src.F -o a.out -I$PNETCDFINC -L$PNETCDFLIB -lpnetcdf endif endif ############################################################################# #### #### #### I B M S P - 2200 C O M P I L A T I O N #### #### #### ############################################################################# ######################### if ($MACHINE == BGL) then if (NETCDF == 0) then setenv NETCDFCMP '' else setenv NETCDFINC /contrib/bgl/pnetcdf/include setenv NETCDFLIB /contrib/bgl/pnetcdf/lib setenv NETCDFINC /bgl/local/netcdf-3.5.1/include setenv NETCDFLIB /bgl/local/netcdf-3.5.1/lib setenv NETCDFINC /contrib/bgl/netcdf/include setenv NETCDFLIB /contrib/bgl/netcdf/lib setenv NETCDFCMP '-L'$NETCDFLIB' -I'$NETCDFINC' -lnetcdf '$NETCDFLIB'/libnetcdf.a' endif ################ if ($ANALIZ == 0) then ################ if ($WORD == 8) then echo ' COMPILE PARALLEL BGL WORD=8' if ($NCARG == 0) then blrts_xlf -o sunrun src.F $OBJECTS -O -qrealsize=8 -qarch=440 -qmaxmem=64000 \ -I/bgl/BlueLight/ppcfloor/bglsys/include \ -L/bgl/BlueLight/ppcfloor/bglsys/lib $NETCDFCMP \ -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts else setenv NCARG_ROOT /contrib/fe_tools/gnu32/ncarg setenv NCARG_LIB /contrib/fe_tools/gnu32/ncarg/lib setenv NCARG_ROOT /contrib/fe_tools/xlc64/ncarg setenv NCARG_LIB /contrib/fe_tools/xlc64/ncarg/lib blrts_xlf -o sunrun src.F -O2 -qhot -qipa -qrealsize=8 -qarch=440 -qmaxmem=64000 \ -I/bgl/BlueLight/ppcfloor/bglsys/include \ -L/bgl/BlueLight/ppcfloor/bglsys/lib \ -L$NCARG_LIB -L/usr/X11R6/lib $NETCDFCMP \ -lncarg -lncarg_gks -lncarg_c -lX11 endif else echo ' COMPILE PARALLEL BGL WORD=4' if ($NCARG == 0) then blrts_xlf -o sunrun src.F $OBJECTS -O -qarch=440 -qmaxmem=64000 \ -I/bgl/BlueLight/ppcfloor/bglsys/include \ -L/bgl/BlueLight/ppcfloor/bglsys/lib $NETCDFCMP \ -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts else setenv NCARG_ROOT /contrib/fe_tools/xlc64/ncarg setenv NCARG_LIB /contrib/fe_tools/xlc64/ncarg/lib setenv NCARG_ROOT /contrib/fe_tools/gnu32/ncarg setenv NCARG_LIB /contrib/fe_tools/gnu32/ncarg/lib ncargf77 -o sunrun src.F $NETCDFCMP endif endif # ls -la if(-f ./sunrun) then chmod a+x ./sunrun size ./sunrun rm -f db.properties serverdb.properties ln -s /bgl/BlueLight/ppcfloor/bglsys/bin/db.properties ln -s /bgl/BlueLight/ppcfloor/bglsys/bin/serverdb.properties echo "cqsub -m vn -n " $NPE " -t " $NTIME " -q " $QUEUE " -C " $DIR $DIR"/sunrun" cqsub -m vn -n $NPE -t $NTIME -q $QUEUE -C $DIR $DIR/sunrun # cqsub -n $NPE -t $NTIME -q $QUEUE -C $DIR $DIR/sunrun endif ################ else ################ echo ' COMPILE ANALIZ BGL WORD=4' setenv NCARG_ROOT /contrib/fe_tools/gnu32/ncarg setenv NCARG_LIB /contrib/fe_tools/gnu32/ncarg/lib ncargf77 src.F $OBJECTS -o sunrun mv -f gmeta gmeta.old || true mv -f fort.9 fort.10 || true mv -f fort.11 fort.12 || true # ls -la if(-f ./sunrun) then chmod a+x ./sunrun size ./sunrun cat > bgl_anl << '\eof' ./sunrun > OUTPUTDIR/JOBNAME.ANout cp ./gmeta OUTGMETA '\eof' sed -e "s#JOBNAME#$JOBNAME#g" bgl_anl > tmp mv -f tmp bgl_anl sed -e "s#OUTGMETA#$OUTGMETA#g" bgl_anl > tmp mv -f tmp bgl_anl sed -e "s#OUTPUTDIR#$OUTPUTDIR#g" bgl_anl > tmp mv -f tmp bgl_anl csh ./bgl_anl & endif ################ endif ################ endif ############################################################################# #### #### #### I B M S P - 2200 C O M P I L A T I O N #### #### #### ############################################################################# # FORTRAN DOCUMENTATION # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/lr71/lr02.HTM # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/ug71/UG02.HTM ############################################################################# # IBM Environmental variables # www.cs.unb.ca/docs/spdocs/ppe/d3d70mst70.html ############################################################################# # -qlanglvl=77std : Full American National Standard FORTRAN 77 # -qlanglvl=90std : Full American National Standard Fortran 90 # -qlanglvl=95std : Full Fortran 95 standard # -qlanglvl=90pure: Fortran 90, less any obsolescent features # -qlanglvl=95pure: Fortran 95, less any obsolescent features # -qsaa : IBM SAA FORTRAN ############################################################################# # FREE (f90,f95) / FIXED (f77) source form # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/lr71/lr24.HTM#HDRF90FREE ############################################################################# if ($MACHINE == IBM) then ######################### echo 'NOW_COMPILE_src.F_IBM' setenv MLIB /usr/local/lib32 if( $machname == 'bluesky') then setenv MLIB /usr/local/lib32 endif if( $machname == 'bluevista') then setenv MLIB /usr/local/lib64 endif if ($NETCDF == 0) then setenv NETCDFCMP '' else if( $machname == 'bluevista') then setenv NETCDFINC /usr/local/apps/netcdf-3.6.0-p1/include setenv NETCDFLIB /usr/local/apps/netcdf-3.6.0-p1/lib setenv NETCDFCMP '-L'$NETCDFLIB' -I'$NETCDFINC' -lnetcdf '$NETCDFLIB'/libnetcdf.a' endif if( $machname == 'bluesky') then setenv NETCDFINC /usr/local/apps/netcdf-3.6.0-p1/include setenv NETCDFLIB /usr/local/apps/netcdf-3.6.0-p1/lib32/r4i4 setenv NETCDFCMP '-L'$NETCDFLIB' -I'$NETCDFINC' -lnetcdf '$NETCDFLIB'/libnetcdf.a' endif endif echo $NETCDFCMP ################################################################# # FORTRAN DOCUMENTATION # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/lr71/lr02.HTM # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/ug71/UG02.HTM ################################################################# # IBM Environmental variables # www.cs.unb.ca/docs/spdocs/ppe/d3d70mst70.html ################################################################# # -qlanglvl=77std : Full American National Standard FORTRAN 77 # -qlanglvl=90std : Full American National Standard Fortran 90 # -qlanglvl=95std : Full Fortran 95 standard # -qlanglvl=90pure: Fortran 90, less any obsolescent features # -qlanglvl=95pure: Fortran 95, less any obsolescent features # -qsaa : IBM SAA FORTRAN ################################################################# # FREE (f90,f95) / FIXED (f77) source form # www.rs6000.ibm.com/doc_link/en_US/a_doc_lib/xlf/lr71/lr24.HTM#HDRF90FREE ################################################################# if ($ANALIZ == 0) then if ($MESSG == MPI) then ######### if ($WORD == 8) then echo ' COMPILE MPI IBM WORD=8' # for ECMWF options, set to MPI64X to 1 setenv MPI64X 0 if ($MPI64X == 1) then echo "COMPILE MPI64" # setenv MP_PREFIX /usr/local/mpi64 # setenv MP_EUILIBPATH ${MP_PREFIX}/ppe.poe/lib # setenv MP_EUINCLPATH ${MP_PREFIX}/ppe.poe/include/thread64 # Tells the resource manager will give you the necessary nodes # setenv MP_RESD YES # Provides more diagnostics if there are errors # setenv MP_INFOLEVEL 2 # Continue to set this for MPI jobs # setenv MP_EUILIB ip # setenv MP_EUILIB us echo 'LIST OF MP ENVIRONMENTAL VARIABLES' setenv|grep MP_ echo ' *** WARNING -O3 option ***' # ${MP_PREFIX}/ppe.poe/bin/mpxlf_r -g -q64 -O3 -qstrct -qfixed=72 src.F # ${MP_PREFIX}/ppe.poe/bin/mpxlf_r -d -O3 -q64 -qfixed=72 \ # -qflag=E:E -qstrict \ # -qarch=auto -qcache=auto -qtune=auto \ # -qalign=4k -qmaxmem=-1 \ # -qsource src.F -L/usr/local/lib64/r8i4 \ # -L${MP_EUILIBPATH} -I${MP_EUINCLPATH} -lm # ${MP_PREFIX}/ppe.poe/bin/mpxlf90_r -d -O3 -q64 -qfixed=72 \ # -qsource src.F -I/usr/local/mpi64/ppe.poe/include/thread64 \ # -L/usr/local/lib32/r8i4 -lm echo " ECMWF options " mpxlf90_r -c -qextname -q64=largetype -qarch=pwr4 -g -O3 -qstrict \ -qsource -qrealsize=8 -NS32648 -qfixed=72 src.F mpxlf90_r -b64 -bbigtoc -bmaxstack:0x800000000 src.o -lm_r \ -L /usr/local/lib/eclib -l ec.LP64.R64.D64.I32._ \ -bloadmap:./load.map # the eclib option is for signal handling # see signal_trap in the code # for speedup the use of the mass library could be explored # -L /usr/local/lib/mass3.2 -lmass else echo "COMPILE MPI32" echo "+++ WARNING: MPI32 not an option at ECMWF +++" # mpxlf -d -O3 -qfixed=72 -qflag=E:E -qstrict -qrealsize=8 \ # -qarch=auto -qcache=auto -qtune=auto -qalign=4k -qmaxmem=-1 \ # -qsource src.F -L/usr/local/lib64/r8i4 -lm # NCAR if( $machname == 'bluesky') then echo 'COMPILE TEST' mpxlf -O0 -qstrict -qrealsize=8 -C -d -g -qflag=I:I \ -qhot -qipa -qcache=auto -qarch=auto -qtune=auto -qmaxmem=-1 \ -qsource src.F -bmaxdata:500000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm \ -L/home/bluesky/wedi/lib -lsig $NETCDFCMP $OBJECTS endif if( $machname == 'bluevista') then mpxlf -O2 -qstrict -qrealsize=8 \ -qhot -qipa -qcache=auto -qarch=auto -qtune=auto -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm $NETCDFCMP $OBJECTS endif endif endif if ($WORD == 4) then echo ' COMPILE MPI IBM WORD=4: *** WARNING -O3 option ***' # echo " ECMWF options " # mpxlf90_r -c -qextname -q64=largetype -qarch=pwr4 -g -O3 -qstrict \ # -qsource -qrealsize=4 -NS32648 -qfixed=72 src.F # mpxlf90_r -b64 -bbigtoc -bmaxstack:0x800000000 src.o -lm_r \ ## -L /usr/local/lib/eclib -l ec.LP64.R32.D64.I32._ \ # -bloadmap:./load.map # echo " NCAR options " if( $machname == 'bluesky') then mpxlf -O2 -qstrict \ -qhot -qipa -qcache=auto -qarch=auto -qtune=auto -qmaxmem=-1 \ -qsource src.F -bmaxdata:500000000 -bmaxstack:256000000 \ -L/usr/local/lib32/r4i4 -lm \ -L/home/bluesky/wedi/lib -lsig $NETCDFCMP $OBJECTS endif if( $machname == 'bluevista') then mpxlf -O2 -qstrict \ -qhot -qipa -qcache=auto -qarch=auto -qtune=auto -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L/usr/local/lib64/r8i4 -lm $NETCDFCMP $OBJECTS endif endif ######### else ######### if ($NCARG == 1) then #### if ($WORD == 8) then echo 'RUN COMPILE WITH NCARGRAPHICS WORD=8' if( $machname == 'bluevista') then setenv NCARG_LIB /usr/local/lib64/r8i4 endif if( $machname == 'bluesky') then setenv NCARG_LIB /usr/local/lib32/r8i4 endif # xlf -O3 -qflag=E:E -qstrict -qrealsize=8 \ # -qarch=auto -qcache=auto -qtune=auto \ # xlf -qflag=E:E -qstrict -qrealsize=8 \ # xlf -O2 -qhot -qipa -qflag=E:E -qstrict -qrealsize=8 \ xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qhot -qipa -qcache=auto -qarch=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:5000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm -lncarg -lncarg_gks -lncarg_c -lX11 $NETCDFCMP $OBJECTS else echo 'RUN COMPILE WITH NCARGRAPHICS WORD=4' if( $machname == 'bluevista') then setenv NCARG_LIB /usr/local/lib64/r4i4 endif if( $machname == 'bluesky') then setenv NCARG_LIB /usr/local/lib32/r4i4 endif echo 'RUN COMPILE WITH NCARGRAPHICS WORD=4' xlf -O2 -qflag=E:E -qstrict \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:5000000000 -bmaxstack:256000000 \ -L$MLIB/r4i4 -lm -lncarg -lncarg_gks -lncarg_c -lX11 $NETCDFCMP $OBJECTS endif #### else #### if ($WORD == 8) then echo 'RUN COMPILE SERIAL IBM WORD=8' xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ # xlf -O3 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 -qsource src.F \ -bmaxdata:2000000000 -bmaxstack:256000000 -L$MLIB/r8i4 -lm $NETCDFCMP $OBJECTS else echo 'RUN COMPILE SERIAL IBM WORD=4' xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 -qsource src.F \ -bmaxdata:2000000000 -bmaxstack:256000000 -L$MLIB/r4i4 -lm $NETCDFCMP $OBJECTS endif #### endif endif endif if ($ANALIZ > 0) then ################ if ($WORD == 8) then echo 'RUN COMPILE ANALIZ WORD=8' if( $machname == 'bluevista') then setenv NCARG_LIB /usr/local/lib64/r8i4 endif if( $machname == 'bluesky') then setenv NCARG_LIB /usr/local/lib32/r8i4 endif if( $NCARG >0 ) then xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm -lncarg -lncarg_gks -lncarg_c -lX11 $NETCDFCMP $OBJECTS else xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm -lX11 $NETCDFCMP $OBJECTS endif else echo 'RUN COMPILE ANALIZ WORD=4' if( $machname == 'bluevista') then setenv NCARG_LIB /usr/local/lib64/r4i4 endif if( $machname == 'bluesky') then setenv NCARG_LIB /usr/local/lib32/r4i4 endif # echo " ECMWF options " # xlf90_r -g -qnoextname -b64 -O2 -qflag=E:E -qstrict -qfixed=72 \ # -qarch=auto -qcache=auto -qtune=auto \ # -qalign=4k -qmaxmem=-1 \ # -qsource src.F -lm_r -b64 -bmaxstack:0x800000000 \ ### -L /usr/local/lib/eclib -l ec.LP64.R32.D64.I32._ \ # -L$NCARG_ROOT/lib -lncarg -lncarg_gks -lncarg_c -lX11 $NETCDFCMP # echo " NCAR options AN" if( $NCARG >0 ) then xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm -lncarg -lncarg_gks -lncarg_c -lX11 $NETCDFCMP $OBJECTS else xlf -O2 -qflag=E:E -qstrict -qrealsize=8 \ -qarch=auto -qcache=auto -qtune=auto \ -qalign=4k -qmaxmem=-1 \ -qsource src.F -bmaxdata:2000000000 -bmaxstack:256000000 \ -L$MLIB/r8i4 -lm -lX11 $NETCDFCMP $OBJECTS endif endif endif echo NOW_COMPILE_src.F_IBM_DONE endif ############################################################################# #### #### #### W O R K S T A T I O N C O M P I L A T I O N #### #### #### ############################################################################# echo NOW_COMPILE_src.F_WRK if ($MACHINE == WRK) then ######################### echo RUN_COMPILE_WRK if ($NCARG == 1) then #COMPILE WITH NCAR_GRAPHICS if ($WORD == 4) then #gnu echo 'f77 -O2 src.F' # echo 'pgf77 src.F' echo 'pgf77 -fast src.F' #gnu f77 src.F $OBJECTS \ # pgf77 src.F $OBJECTS \ pgf77 -fast src.F $OBJECTS \ -L/usr/local/ncarg/lib -L/usr/X11R6/lib -L/usr/dt/lib \ -lncarg -lncarg_gks -lncarg_c -lX11 -lm -lf2c #gnu -L/usr/local/ncarg/lib -L/usr/openwin/lib -L/usr/dt/lib \ #gnu -lncarg -lncarg_gks -lncarg_c -lX11 -lm else # echo 'f77 -r8 src.F' # f77 -r8 src.F $OBJECTS \ # -L/usr/local/ncarg/lib -L/usr/openwin/lib -L/usr/dt/lib \ # -lncarg -lncarg_gks -lncarg_c -lX11 -lm echo 'NCAR_GRAPHICS with double prec. not implemented' echo 'If you need a double precision version have your ' echo 'system administrator contact ncargfx@ncar.ucar.edu' endif else #COMPILE WITHOUT NCAR_GRAPHICS if ($WORD == 4) then #gnu echo 'f77 -O1 src.F' # echo 'pgf77 src.F' echo 'pgf77 -fast src.F' #gnu f77 -O1 src.F $OBJECTS # pgf77 src.F $OBJECTS pgf77 -fast src.F $OBJECTS #LINUX g77 src.F $OBJECTS endif if ($WORD == 8) then #gnu echo 'f77 -O1 -r8 src.F' # echo 'pgf77 -r8 src.F' echo 'pgf77 -r8 -fast src.F' pgf77 -r8 -fast src.F $OBJECTS # pgf77 -r8 src.F $OBJECTS #gnu f77 -O1 -r8 src.F #SGI f77 -O1 -r8 src.F $OBJECTS #SUN f77 -O1 -r8 -i4 src.F $OBJECTS endif endif endif ############################################################################# #### #### #### R U N E X E C U T A B L E C O D E #### #### #### ############################################################################# echo NOW_EXECUTE_code #ls -la date # if(-f a.out) then chmod a+x ./a.out endif # ########################## if ($MACHINE == NEC) then ########################## size ./a.out echo RUN_EXECUTABLE_NEC if ($MESSG == MPI) then # mpirun -np $NPE a.out >& output.job mpirun -np $NPE a.out else echo ' a.out' ./a.out >& output.job endif endif ######################### if ($MACHINE == PVP) then ######################### size ./a.out ja echo RUN_EXECUTABLE_PVP if ($MESSG == MPI) then # mpirun -np $NPE a.out >& output.job mpirun -np $NPE a.out else if ($PERFM == 1) then echo 'PERFORMANCE TOOL - JUMPVIEW' echo 'use "jumpview" for "jump.data" out file' echo 'jt ./a.out' jt ./a.out else echo 'hpm -g 0 a.out' hpm -g 0 a.out endif endif ja -st endif ######################### if ($MACHINE == T3E) then ######################### size ./a.out ja echo RUN_EXECUTABLE_T3E ./a.out >& output.job ja -st endif ######################### if ($MACHINE == O2K) then ######################### size ./a.out echo RUN_EXECUTABLE_SGI_ORIGIN_2000 if ($MESSG == MPI) then # mpirun -cpr -miser -np $NPE ./a.out mpirun -cpr -np $NPE ./a.out else env NPES=$NPE ./a.out endif endif ######################### if ($MACHINE == HP) then ######################### size ./a.out echo RUN_EXECUTABLE_HP if ($MESSG == MPI) then mpirun -np $NPE ./a.out else ./a.out endif endif ######################### if ($MACHINE == WRK) then ######################### ./a.out endif ######################### if ($MACHINE == LNX) then ########################## qsub run_paral endif ########################## if ($MACHINE == IBM) then ########################## size ./a.out echo RUN_EXECUTABLE_IBM if ($MESSG == MPI) then echo 'submit parallel script' if( $machname == 'bluevista') then bsub -W $NTIME < run_paral endif if( $machname == 'bluesky') then llsubmit run_paral endif else echo 'submit serial script' # batch if( $BATCH == 1 ) then if( $machname == 'bluevista') then bsub -W $NTIME < run_serial endif if( $machname == 'bluesky') then llsubmit run_serial endif else limit -h chmod 755 ./run_serial ./run_serial >& $OUTPUTDIR/out.serial.$JOBNAME cat $OUTPUTDIR/out.serial.$JOBNAME || true endif endif endif ########################## if ($MACHINE == CPQ) then ########################## echo RUN_EXECUTABLE_COMPAQ if ($MESSG == MPI) then # dmpirun -np $NPE a.out echo 'submit parallel script' qsub run_paral else echo 'submit serial script' qsub run_serial # a.out endif endif ############################################################################# # |--> <--| # # |--> P O S T P R O C E S S I N G <--| # # |--> <--| # ############################################################################# date ###################################################### ## write the history tape to MSS (NCAR mas storage) ## ###################################################### #setenv NAME PVE3O.MM11.PSMA # echo $NAME # mswrite -t 365 fort.9 /PRUSA/IBCZPV/$NAME #rcp gmeta andii@cassia.mmm.ucar.edu:/data2/cs/andii/IBCZPV/$NAME #mswrite -t 365 fort.9 /PRUSA/IBCZP/ECMA1111 #mswrite -t 90 fort.out /PRUSA/BINTEST/OUT.HP4.PVP8 #cp itape /ptmp/prusa/T3E.2D.MPI2 ########################################################### ## write the history tape to UNITREE (NERSC mas storage) ## ## DIRECTORY :/home/mp84/your_directory/ ## ## or remote copy the history tape to NCAR ## ########################################################### #masput fort.9 /home/mp84/andii/prusa/pr2D.1.24.10.mas #rcp fort.9 andii@ouray.ucar.edu:/usr/tmp/andii/t3e_a10.15.1 #rcp ftn09 andii@ouray.ucar.edu:/usr/tmp/andii/t3e_a10.15.1 ##########i########################## ## copy or remote copy output file ## ##################################### #rcp output.t3d andii@ouray.ucar.edu:/usr/tmp/andii/out.t3de_01 #cp output.t3d /ptmp/andii/output.t3e.mpi2 if ($NCARG == 1) then # echo 'la2.io1.n1' #rcp gmeta andii@cassia.mmm.ucar.edu:/data2/cs/andii/IBCZ2/la2.io1.n1 #rcp gmeta andii@cassia.mmm.ucar.edu:/data2/cs/andii/IBCZ2/la2.io1.n1 # echo 's0ma3.io1.is1.n1.id1' #rcp gmeta andii@cassia.mmm.ucar.edu:/data2/cs/andii/IBCZ2/s0ma3.io1.is1.n1.id1 endif if ($VIS5D == 1) then # tar cvf outv5d.tar *.v5d # rcp outv5d.tar andii@cassia.mmm.ucar.edu:/data2/cs/andii/1Dorg.v5d.2d.tar endif ################# ## notify user ## ################# # mail prusa@ucar.edu < output.t3d ##ja -st #date ############################################################################# # |--> <--| # # |--> E N D O F S C R I P T <--| # # |--> <--| # ############################################################################# exit