lagranto.20crcontracklagranto.arpegelagranto.cesmlagranto.cosmolagranto.ecmwflagranto.iconlagranto.oceanlagranto.umlagranto.wrflivecdpvinversion.ecmwftropofold.echam

BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → / @ 7

  → / @ 8

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

No changes between revisions

Ignore whitespace Rev 7 → Rev 8

/tags/1.0/LICENSE.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/pdf
Property changes:
Added: svn:mime-type
+application/pdf
\ No newline at end of property

/tags/1.0/bin/lagranto
0,0 → 1,869
#!/bin/csh
# ---------------------------------------------------------------------
# Usage
# ---------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}
# Write usage information
if ( (${#argv} == 0) ) then
echo
${LAGRANTO}/bin/lagrantohelp lagranto short
echo
exit 0
endif
# Check whether LAGRANTO was set with setenv
set test = `setenv | grep LAGRANTO`
if ( "${test}" == "" ) then
echo "---------------------------------------------------------------------"
echo "Please set environmental variable <LAGRANTO> to your source directory"
echo 'csh > setenv LAGRANTO ${TO_YOUR_LAGRANTO_INSTALLATION}'
echo "---------------------------------------------------------------------"
exit 1
endif
# ---------------------------------------------------------------------
# Set some general parameters
# ---------------------------------------------------------------------
# Set the prefix of the primary and secondary data files
set charp = 'P'
set chars = 'S'
# Set the name of the run script
set runscript = "runscript"
# Remember the calling directory
set calldir = $PWD
# ---------------------------------------------------------------------
# Parameter handling
# ---------------------------------------------------------------------
# Write title
echo
echo '========================================================='
echo ' *** START OF LAGRANTO *** '
echo
# Save the complete argument list
set lagranto_call = "$*"
echo '---- HANDLE ARGUMENTS -----------------------------------'
echo
# Get fixed arguments
if (${#argv} == 1) then
set mode = '-open'
set caseid = "$1"
shift
else if (${#argv} == 2) then
set mode = "$1"
set caseid = "$2"
shift
shift
else
set caseid = "$1"
set startdate = "$2"
set enddate = "$3"
set startf = "$4"
set select = "$5"
set mode = "runlagranto"
shift
shift
shift
shift
shift
endif
# Split <caseid> into base and appendix
set casebase = `(echo $caseid | awk -F "." '{print $1}')`
set appendix = `(echo $caseid | awk -F "." '{print $2}')`
if ( "${appendix}" != "" ) then
set appendix = ".${appendix}"
endif
# Set the directories (depending on <caseid>)
if ( "${casebase}" == "local" ) then
set cdfdir = $PWD
set tradir = $PWD
else if ( "${casebase}" == "interim" ) then
set cdfdir = /net/dansgaard/atmosdyn/erainterim/cdf/
set tradir = $PWD
else if ( "${casebase}" == "analysis" ) then
set cdfdir = 'TO_BE_SPECIFIED'
set tradir = $PWD
echo "ERROR: caseid (analysis) not yet implemented"
exit 1
else if ( "${casebase}" == "forecast" ) then
set cdfdir = 'TO_BE_SPECIFIED'
set tradir = $PWD
echo "ERROR: caseid (forecast) not yet implemented"
exit 1
else
set cdfdir = ${HOME}/cdf/${casebase}
set tradir = ${HOME}/tra/${casebase}
endif
# Change to the run directory if requested
if ( "${mode}" == "-open" ) then
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
echo "[${count}] ${folder}"
end
echo
echo "Please select directory [0...${count}]"
set id = $<
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
if ( "${count}" == "${id}" ) then
cd ${folder}
xterm &
endif
end
exit 0
endif
# Remove the whole run directory if requested
if ( "${mode}" == "-remove" ) then
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
echo "[${count}] ${folder}"
end
echo
echo "Please select directory [0...${count}, all]"
set id = $<
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
if ( ( "${count}" == "${id}" ) | ( "${id}" == "all" ) ) then
\rm -r ${folder}
endif
end
exit 0
endif
# Show the trajectory file
if ( "${mode}" == "-show" ) then
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
echo "[${count}] ${folder}"
end
echo
echo "Please select directory [0...${count}]"
set id = $<
set count = 0
foreach folder ( ${tradir}/ntr_*_${caseid}_* )
@ count = ${count} + 1
if ( "${count}" == "${id}" ) then
cd ${folder}
set filename = ` sed -ne '9,9p' runscript.sh | cut -c 2-`
${LAGRANTO}/goodies/trainfo.sh ${filename} list | less
endif
end
exit 0
endif
# Decide whether <select> is a file or an explicit criterion
set flag_select = 'file'
set test = `echo ${select} | grep ':' | wc -c`
if ( "${test}" != "0" ) then
set flag_select = 'criterion'
endif
# Decide whether <startf> is a file or an explicit criterion
set flag_startf = 'file'
set test = `echo ${startf} | grep ' ' | wc -c`
if ( "${test}" != "0" ) then
set flag_startf = 'point'
endif
set test = `echo ${startf} | grep '@' | wc -c`
if ( "${test}" != "0" ) then
set flag_startf = 'criterion'
endif
# Write some status information
echo " Case ID : ${caseid}"
echo " Start date : ${startdate}"
echo " End date : ${enddate}"
if ( "${flag_startf}" == "criterion" ) then
echo " Start file : ${startf} [criterion] -> startf.criterion [file]"
else if ( "${flag_startf}" == "file" ) then
echo " Start points : ${startf} [file]"
else if ( "${flag_startf}" == "point" ) then
echo " Start points : ${startf} [point] -> startf [file]"
endif
if ( "${flag_select}" == "criterion" ) then
echo " Selection : ${select} [criterion] -> selectf.criterion [file]"
else
echo " Selection : ${select} [file]"
endif
echo
# Set defaults for flags
set jumpflag = ""
set tracefile = "tracevars"
set outfile = "lsl_${startdate}"
set keepflag = ""
set prepflag = ""
set logfile = "${runscript}.logfile"
set regionf = "regionf"
set changet = "false"
# Handle flags
while ( $#argv > 0 )
switch ( $argv[1] )
echo $argv[1]
case -j
set jumpflag = "-j"
echo " Flag '-j [jump]' -> True "
echo
breaksw
case -prep
set prepflag = "prep"
echo " Flag '-prep [prepare only]' -> ${prepflag} "
echo
breaksw
case -noclean
set keepflag = "keep"
echo " Flag '-noclean [no cleaning]' -> ${keepflag} "
echo
breaksw
case -o
set outfile = $argv[2]
echo " Flag '-o [output]' -> ${outfile} "
echo
breaksw
case -v
set tracefile = $argv[2]
echo " Flag '-v [tracevars]' -> ${tracefile} "
echo
shift
breaksw
case -r
set regionfile = $argv[2]
echo " Flag '-r [regionfile]' -> ${regionfile} "
echo
shift
breaksw
case -log
set logfile = "/dev/stdout"
echo " Flag '-v [log]' -> ${logfile} "
breaksw
case -changet
set changet = "true"
echo " Flag '-changet [change times]'-> True "
echo
breaksw
endsw
shift;
end
# Decide whether a tracevars file is given or not
if ( -f ${tradir}/${tracefile} ) then
set flag_tracevars = 'file'
else
set flag_tracevars = 'nil'
endif
echo
if ( "${flag_tracevars}" == "file" ) then
echo " Trace Vars : ${tracefile} [file]"
else
echo " Trace Vars : [no fields are traced]"
endif
echo
# Set the name of the run directory (forward/backward distinction)
set dir = 'f'
set range = `${LAGRANTO}/bin/gettidiff.sh ${enddate} ${startdate}`
if ( ${range} < 0 ) then
set dir = 'b'
set range = `${LAGRANTO}/bin/gettidiff.sh ${startdate} ${enddate}`
endif
set rundir = ${tradir}/ntr_${startdate}_${dir}${range}_${caseid}
if ( "${flag_startf}" == "criterion" ) then
set rundir = "${rundir}_startf"
else if ( "${flag_startf}" == "point" ) then
set rundir = "${rundir}_startf"
else if ( "${flag_startf}" == "file" ) then
set rundir = "${rundir}_${startf}"
endif
if ( "${flag_select}" != "file" ) then
set rundir = "${rundir}_selectf"
else
set rundir = "${rundir}_${select}"
endif
# Write directory names
echo '---- DIRECTORIES ----------------------------------------'
echo
echo " CDF = ${cdfdir}"
echo " TRA = ${tradir}"
echo " RUN = ${rundir}"
# Check whether CDF and TRA directories exist
if ( ! -d ${cdfdir} ) then
echo 'Cannot find CDF directory ... Stop'
exit 1
endif
if ( ! -d ${tradir} ) then
echo 'Cannot find TRA directory ... Stop'
exit 1
endif
# Create the run directory
if ( ! -d ${rundir} ) then
mkdir ${rundir}
endif
if ( ! -d ${rundir} ) then
echo 'Cannot create RUN directory ... Stop'
exit 1
endif
# ---------------------------------------------------------------------
# Handle the time specifier - startdate, enddate
# ---------------------------------------------------------------------
echo
echo '---- TIME RANGE -----------------------------------------'
echo
# Check format of start and end date - must be the same
set ns=`echo $startdate | sed -e 's/_[0-9]*//' | wc -c`
set ne=`echo $enddate | sed -e 's/_[0-9]*//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( $ns != 9 ) then
echo " ERROR: Date format must be yyyymmdd ***"
exit 1
endif
set ns=`echo $startdate | sed -e 's/[0-9]*_//' | wc -c`
set ne=`echo $enddate | sed -e 's/[0-9]*_//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( ( $ns != 5 ) & ( $ns != 3 ) ) then
echo " ERROR: Time format must be hh(mm) ***"
exit 1
endif
# Split the start and end date into <yymmdd_hh and mm>
set startdate_ymdh = `echo $startdate | cut -c 1-11`
set startdate_min = `echo $startdate | cut -c 12-13`
if ( $startdate_min == "" ) set startdate_min = 00
set enddate_ymdh = `echo $enddate | cut -c 1-11`
set enddate_min = `echo $enddate | cut -c 12-13`
if ( $enddate_min == "" ) set enddate_min = 00
# Get the time difference between <start_ymdh> and <end_ymdh> date
# Decide whether trajectoriesare forward or backward
set timediff_hh = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${startdate_ymdh}`
if ( $timediff_hh == 0 ) then
if ( $enddate_min > $startdate_min ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
endif
else if ( $timediff_hh > 0 ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
@ timediff_hh = $idir * $timediff_hh
endif
# Get also minutes for time difference, if <start_min> or <end_min> != 0
set timediff_mm=
if ( $startdate_min != 00 || $enddate_min != 00 ) then
@ min = ( $enddate_min - $startdate_min )
if ( $min == 0 ) then
set timediff_mm=
else if ( $min > 0 ) then
if ( $idir == 1 ) then
set timediff_mm=$min
else
@ timediff_hh --
@ timediff_mm = 60 - $min
endif
else
if ( $idir == 1 ) then
@ timediff_hh --
@ timediff_mm = 60 + $min
else
@ timediff_mm = 0 - $min
endif
endif
endif
# Set the reference date equal to the startdate
set refdate=${startdate}
# Write status information
echo "Time range : ${startdate} -> ${enddate}"
if ( ${timediff_mm} != "" ) then
echo "Time difference : ${timediff_hh} h ${timediff_mm} min"
else
echo "Time difference : ${timediff_hh} h"
endif
echo "Direction : ${direction} (${idir})"
echo "Reference date : ${refdate}"
# ---------------------------------------------------------------------
# Decide which files are needed and check availability
# ---------------------------------------------------------------------
echo
echo '---- INPUT FILES ----------------------------------------'
echo
# Change to input data (cdf) directory
cd ${cdfdir}
echo
# Take the time increment from flag list ('nil', if not defined)
set timeinc = 'nil'
# Find a first data file (if possible corresponding to start/end date
# If starttime is not a data time, take the first file in the direectory
if ( $direction == "f" ) then
set file=${charp}${startdate_ymdh}
else
set file=${charp}${enddate_ymdh}
endif
if ( ! -f $file ) then
set file=`ls ${charp}[0-9_]*[0-9] | head -1 | sed -e 's/@//'`
endif
# Determine timeinc (the time difference in hours between two data file)
# if not already defined with option -i
if ( ${timeinc} == "nil" ) then
set date1=`echo $file | cut -c 2-12`
set n=`ls ${charp}[0-9_]*[0-9] | grep -n $date1 | awk -F: '{print $1}'`
@ n ++
set date2=`ls ${charp}[0-9_]*[0-9] | head -$n | tail -1 | cut -c 2-12`
set timeinc=`${LAGRANTO}/goodies/gettidiff $date2 $date1`
endif
if ( $timeinc == 0 ) then
echo " ERROR: cannot set the time increment between input files ***"
exit 1
endif
# Search the first file to use
set flag=0
set td=
foreach i ( ${charp}????????_?? )
set date = `echo $i | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
end
# if no P/T-files are available for the specified time period, then $td is
# still undefined
if ( $td == "" ) then
echo " ERROR: no data files available for the specified time period"
exit 1
endif
# Everything is fine so far: proceed
label2:
# Calculate the number of further files
@ num = ( $timediff_hh + $td ) / $timeinc + 1
@ dum1 = ( $num - 1 ) * $timeinc
@ dum2 = $timediff_hh + $td
if ( $dum1 != $dum2 ) @ num ++
# Get a list of all needed files
set numfiles=$num
set sfiles=1
while ( $num > 1 )
set date=`${LAGRANTO}/goodies/newtime $date $timeinc`
if ( ! -f ${charp}${date} ) then
echo " ERROR: file with primary data is missing for $date"
exit 1
else if ( ! -f ${chars}${date} ) then
set sfiles=0
set datfiles=`echo $datfiles $date`
else
set datfiles=`echo $datfiles $date`
endif
@ num --
end
# Write some status information
echo "Primary file prefix : ${charp}"
echo "Secondary file prefix : ${chars}"
echo "Time increment for input files : ${timeinc}"
echo "# input files : ${numfiles}"
echo "${charp} files availability : 1"
echo "${chars} files availability : ${sfiles}"
echo "First input file : $datfiles[1] "
echo "Last input file : $datfiles[$numfiles] "
# ---------------------------------------------------------------------
# Prepare run directory - copy all needed files
# ---------------------------------------------------------------------
echo
echo '---- PREPARE RUN DIRECTORY ------------------------------'
echo
# Change to run directory
cd ${rundir}
echo
# Link cdf input files
foreach date ( $datfiles )
if ( -f ${cdfdir}/${charp}${date} ) then
if ( ! -f ${charp}${date} ) then
ln -s ${cdfdir}/${charp}${date} ${charp}${date}
echo "Linking ${date} "
else
echo "Existing ${date} "
endif
endif
if ( -f ${cdfdir}/${chars}${date} ) then
if ( ! -f ${chars}${date} ) then
ln -sf ${cdfdir}/${chars}${date} ${chars}${date}
endif
endif
end
# Change times on netCDF files relative to reference date
if ( "${changet}" == "true" ) then
echo
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${charp}${i}
end
if ( ${sfiles} == 1 ) then
echo
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${chars}${i}
end
endif
endif
# Get the constants file for each file
set first = 1
foreach date ( $datfiles )
set cstname = `ncdump -h ${charp}${date} | grep constants_file_name`
set cstname = `echo \'${cstname}\' | awk -F\" '{print $2}'`
if ( -f ${cdfdir}/${cstname} ) then
if ( ! -f ${cstname} ) then
ln -s ${cdfdir}/${cstname} ${cstname}
echo "Linking constants file ${cstname}"
set first = 0
else if ( "${first}" == "1" ) then
echo "Existing constants file ${cstname}"
set first = 0
endif
endif
end
# Copy the tracevars file
if ( "${flag_tracevars}" == "file" ) then
if ( -f ${tradir}/${tracefile} ) then
\cp ${tradir}/${tracefile} .
endif
endif
# Copy the start file/criterion
if ( "${flag_startf}" == "criterion" ) then
\rm -f startf.criterion
echo ${startf} > startf.criterion
set startf = "startf.criterion"
else if ( "${flag_startf}" == "file" ) then
if ( -f ${tradir}/${startf} ) then
\cp ${tradir}/${startf} .
endif
else if ( "${flag_startf}" == "point" ) then
\rm -f startf
echo ${startf} > startf
set startf = "startf"
set flag_startf = "file"
endif
# Copy the select file/criterion
if ( "${flag_select}" == "criterion" ) then
\rm -f select.criterion
echo ${select} > select.criterion
set select = "select.criterion"
else
if ( -f ${tradir}/${select} ) then
\cp ${tradir}/${select} .
endif
endif
# ---------------------------------------------------------------------
# Prepare the run script
# ---------------------------------------------------------------------
echo
echo '---- PREPARE RUN SCRIPT ---------------------------------'
echo
# Remove runscript if it already exists
if ( -f ${runscript}.sh ) then
\rm -f ${runscript}.sh
endif
# Write header
echo '#\!/bin/csh' >! ${runscript}.sh
echo "#" >> ${runscript}.sh
echo "#----- Calling command" >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo "# lagranto ${lagranto_call} " >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo "#----- Output file " >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo "# ${outfile} " >> ${runscript}.sh
echo "#" >> ${runscript}.sh
# Decide whether <create_startf> has to be run
if ( "${flag_startf}" == "criterion" ) then
echo "#------ Run <create_startf>" >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo ${LAGRANTO}/bin/create_startf.sh ${startdate} startf \"`cat startf.criterion`\" -t ${tracefile} -regionf ${regionf} >> ${runscript}.sh
echo "#" >> ${runscript}.sh
set startf = "startf"
endif
# Check whether startfile is ready
cat >> ${runscript}.sh <<EOF
#------ Abort if no startf is available
#
if ( ! -f ${startf} ) then
echo " ERROR: no start file available .... Stop"
exit 1
endif
EOF
# Decide wich intermediate format is used (needed for efficient communication between different programs)
set iform1 = ""
set iform2 = ""
if ( "${tracefile}" != "" ) set iform1 = ".4"
if ( "${select}" != "nil" ) set iform2 = ".4"
# Remove all trajectory files which might already be there
cat >> ${runscript}.sh <<EOF
#
#------ Remove existing trajectory files
#
if ( -f ${outfile}${iform1} ) then
\rm -f ${outfile}${iform1}
endif
if ( -f ${outfile}${iform2} ) then
\rm -f ${outfile}${iform2}
endif
if ( -f ${outfile} ) then
\rm -f ${outfile}
endif
EOF
# Write call to <caltra> into runscript
echo "#" >> ${runscript}.sh
echo "#------ Run <caltra>" >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo ${LAGRANTO}/bin/caltra.sh ${startdate} ${enddate} startf ${outfile}${iform1} ${jumpflag} >> ${runscript}.sh
# Check whether caltra was successful
cat >> ${runscript}.sh <<EOF
#
#------ Abort if caltra was not successful
#
if ( ! -f ${outfile}${iform1} ) then
echo " ERROR: caltra failed .... Stop"
exit 1
endif
EOF
# Decide whether <trace> has to be run
if ( "${tracefile}" != "" ) then
echo "#" >> ${runscript}.sh
echo "#------ Run <trace>" >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo ${LAGRANTO}/bin/trace.sh ${outfile}${iform1} ${outfile}${iform2} -v ${tracefile} >> ${runscript}.sh
endif
# Check whether trace was successful
cat >> ${runscript}.sh <<EOF
#
#------ Abort if trace was not successful
#
if ( ! -f ${outfile}${iform2} ) then
echo " ERROR: trace failed .... Stop"
exit 1
endif
EOF
# Decide whether <select> has to be run
if ( "${select}" != "nil" ) then
echo "#" >> ${runscript}.sh
echo "#------ Run <select>" >> ${runscript}.sh
echo "#" >> ${runscript}.sh
echo ${LAGRANTO}/bin/select.sh ${outfile}${iform2} ${outfile} \"`cat ${select}`\" -regionf ${regionf} >> ${runscript}.sh
echo "#" >> ${runscript}.sh
endif
# Show runscript on screen
more ${runscript}.sh
# Change runscript to executable
chmod u+x ${runscript}.sh
# Decide whether to stop at this place (only preparation for Lagranto run)
if ( "${prepflag}" == "prep" ) then
echo
echo '---- READY TO RUN ----- ---------------------------------'
echo
echo " Would you like to change to the rundirectory [y/n] "
set id = $<
if ( ( "${id}" == "y" ) | ( "${id}" == "Y" ) ) then
cd ${rundir}
xterm &
endif
exit 0
endif
# Define environment variable for the case
echo
echo '---- REMEMBER MOST RECENT CALL --------------------------'
echo
cd ${calldir}
if ( -f lagranto.param ) \rm lagranto.param
echo "${rundir}" >! lagranto.param
echo "${outfile}" >> lagranto.param
cd ${rundir}
echo
echo " run directory + output file -> lagranto.param"
# ---------------------------------------------------------------------
# Run lagranto
# ---------------------------------------------------------------------
echo
echo '---- RUN LAGRANTO ---------------------------------------'
echo
if ( "${logfile}" != "/dev/stdout" ) then
echo "log goes to ${logfile}"
endif
# Remove logfile
if ( "${logfile}" != "/dev/stdout" ) then
\rm -f ${logfile}
endif
# Run it
${rundir}/${runscript}.sh > ${logfile}
# Check for errors in logfile
if ( "${logfile}" != "/dev/stdout" ) then
grep ERROR ${logfile}
endif
# ---------------------------------------------------------------------
# Make clean and finish lagranto run
# ---------------------------------------------------------------------
# Remove unneeded files
\rm -f fort.9
# Remove files if requested
if ( "${keepflag}" != "keep" ) then
echo
echo '---- MAKING CLEAN ---------------------------------------'
echo
cd ${rundir}
set runscript = "${runscript}.sh"
foreach file ( `\ls -L1` )
set id = "0"
if ( "${file}" == "${outfile}" ) set id="1"
if ( "${file}" == "${runscript}" ) set id="1"
if ( "${file}" == "${logfile}" ) set id="1"
if ( "${id}" == "0" ) \rm -f ${file}
end
endif
# Everything is fine!
echo
echo ' *** END OF LAGRANTO *** '
echo '========================================================='
echo
exit 0
Property changes:
Added: svn:executable

/tags/1.0/bin/lagrantohelp
0,0 → 1,102
#!/bin/csh
# ---------------------------------------------------------------------------
# Set parameters - handle arguments
# ---------------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}
set dir = ${LAGRANTO}/docu/
set viewer = okular
set nargv = ${#argv}
if ( (${#argv} == 0) ) then
nroff -man ${dir}/man/lagrantohelp.0 | less
exit 0
endif
if ( "${nargv}" == "1" ) then
set mode = "$1"
set verb = "long"
else if ( "${nargv}" == "2" ) then
set mode = "$1"
set verb = "$2"
endif
# ---------------------------------------------------------------------------
# Tutorial, Reference, Presentation, Future Plans
# ---------------------------------------------------------------------------
if ( "$mode" == "future" ) then
nroff -man ${dir}/man/futureplans.0 | less
exit 0
endif
if ( "$mode" == "tutorial" ) then
${viewer} ${dir}/tutorial/tutorial.pdf
exit 0
endif
if ( "$mode" == "reference" ) then
${viewer} ${dir}/reference/reference.pdf
exit 0
endif
if ( "$mode" == "presentation" ) then
${viewer} ${dir}/presentation/presentation.pdf
exit 0
endif
# ---------------------------------------------------------------------------
# Manual
# ---------------------------------------------------------------------------
if ( "${verb}" == "long" ) then
nroff -man ${dir}/man/${mode}.0 | less
exit 0
endif
if ( "${verb}" == "short" ) then
echo
nroff -man ${dir}/man/${mode}.0 | grep -A 1 SYNOPSIS
echo
set i0 = `nroff -man ${dir}/man/${mode}.0 | grep -n EXAMPLES | awk -F ":" '{print $1}'`
set i1 = `nroff -man ${dir}/man/${mode}.0 | grep -n AUTHOR | awk -F ":" '{print $1}'`
set i1 = `echo "$i1 - 1" | bc`
if ( ( "$i0" != "" ) & ( "$i1" != "" ) ) then
nroff -man ${dir}/man/${mode}.0 | sed -ne ${i0},${i1}p
endif
endif
if ( "${verb}" == "synopsis" ) then
echo
nroff -man ${dir}/man/${mode}.0 | grep -A 1 SYNOPSIS
echo
exit 0
endif
if ( "${verb}" == "parameter" ) then
set i0 = `nroff -man ${dir}/man/${mode}.0 | grep -n PARAMETERS | awk -F ":" '{print $1}'`
set i1 = `nroff -man ${dir}/man/${mode}.0 | grep -n EXAMPLES | awk -F ":" '{print $1}'`
set i1 = `echo "$i1 - 1" | bc`
echo $i0
echo $i1
if ( ( "$i0" != "" ) & ( "$i1" != "" ) ) then
nroff -man ${dir}/man/${mode}.0 | sed -ne ${i0},${i1}p
endif
exit 0
endif
if ( "${verb}" == "examples" ) then
set i0 = `nroff -man ${dir}/man/${mode}.0 | grep -n EXAMPLES | awk -F ":" '{print $1}'`
set i1 = `nroff -man ${dir}/man/${mode}.0 | grep -n AUTHOR | awk -F ":" '{print $1}'`
set i1 = `echo "$i1 - 1" | bc`
if ( ( "$i0" != "" ) & ( "$i1" != "" ) ) then
nroff -man ${dir}/man/${mode}.0 | sed -ne ${i0},${i1}p
endif
exit 0
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/caltra/caltra.f
0,0 → 1,943
PROGRAM caltra
C ********************************************************************
C * *
C * Calculates trajectories *
C * *
C * Heini Wernli first version: April 1993 *
C * Michael Sprenger major upgrade: 2008-2009 *
C * *
C ********************************************************************
implicit none
c --------------------------------------------------------------------
c Declaration of parameters
c --------------------------------------------------------------------
c Maximum number of levels for input files
integer nlevmax
parameter (nlevmax=100)
c Maximum number of input files (dates, length of trajectories)
integer ndatmax
parameter (ndatmax=500)
c Numerical epsilon (for float comparison)
real eps
parameter (eps=0.001)
c Distance in m between 2 lat circles
real deltay
parameter (deltay=1.112E5)
c Numerical method for the integration (0=iterative Euler, 1=Runge-Kutta)
integer imethod
parameter (imethod=1)
c Number of iterations for iterative Euler scheme
integer numit
parameter (numit=3)
c Input and output format for trajectories (see iotra.f)
integer inpmode
integer outmode
c Filename prefix (typically 'P')
character*1 prefix
parameter (prefix='P')
c --------------------------------------------------------------------
c Declaration of variables
c --------------------------------------------------------------------
c Input parameters
integer fbflag ! Flag for forward/backward mode
integer numdat ! Number of input files
character*11 dat(ndatmax) ! Dates of input files
real timeinc ! Time increment between input files
real per ! Periodicity (=0 if none)
integer ntra ! Number of trajectories
character*80 cdfname ! Name of output files
real ts ! Time step
real tst,ten ! Shift of start and end time relative to first data file
integer deltout ! Output time interval (in minutes)
integer jflag ! Jump flag (if =1 ground-touching trajectories reenter atmosphere)
real wfactor ! Factor for vertical velocity field
character*80 strname ! File with start positions
character*80 timecheck ! Either 'yes' or 'no'
c Trajectories
integer ncol ! Number of columns for insput trajectories
real,allocatable, dimension (:,:,:) :: trainp ! Input start coordinates (ntra,1,ncol)
real,allocatable, dimension (:,:,:) :: traout ! Output trajectories (ntra,ntim,4)
integer reftime(6) ! Reference date
character*80 vars(200) ! Field names
real,allocatable, dimension (:) :: xx0,yy0,pp0 ! Position of air parcels
integer,allocatable, dimension (:) :: leftflag ! Flag for domain-leaving
real xx1,yy1,pp1 ! Updated position of air parcel
integer leftcount ! Number of domain leaving trajectories
integer ntim ! Number of output time steps
c Meteorological fields
real,allocatable, dimension (:) :: spt0,spt1 ! Surface pressure
real,allocatable, dimension (:) :: uut0,uut1 ! Zonal wind
real,allocatable, dimension (:) :: vvt0,vvt1 ! Meridional wind
real,allocatable, dimension (:) :: wwt0,wwt1 ! Vertical wind
real,allocatable, dimension (:) :: p3t0,p3t1 ! 3d-pressure
c Grid description
real pollon,pollat ! Longitude/latitude of pole
real ak(nlevmax) ! Vertical layers and levels
real bk(nlevmax)
real xmin,xmax ! Zonal grid extension
real ymin,ymax ! Meridional grid extension
integer nx,ny,nz ! Grid dimensions
real dx,dy ! Horizontal grid resolution
integer hem ! Flag for hemispheric domain
real mdv ! Missing data value
c Auxiliary variables
real delta,rd
integer itm,iloop,i,j,k,filo,lalo
integer ierr,stat
integer cdfid,fid
real tstart,time0,time1,time
real reltpos0,reltpos1
real xind,yind,pind,pp,sp,stagz
character*80 filename,varname
integer reftmp(6)
character ch
real frac,tload
integer itim
integer wstep
real x1,y1
c Externals
real int_index4
external int_index4
c --------------------------------------------------------------------
c Start of program, Read parameters
c --------------------------------------------------------------------
c Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM CALTRA ***'
print*
c Open the parameter file
open(9,file='caltra.param')
c Read flag for forward/backward mode (fbflag)
read(9,*) fbflag
c Read number of input files (numdat)
read(9,*) numdat
if (numdat.gt.ndatmax) then
print*,' ERROR: too many input files ',numdat,ndatmax
goto 993
endif
c Read list of input dates (dat, sort depending on forward/backward mode)
if (fbflag.eq.1) then
do itm=1,numdat
read(9,'(a11)') dat(itm)
enddo
else
do itm=numdat,1,-1
read(9,'(a11)') dat(itm)
enddo
endif
c Read time increment between input files (timeinc)
read(9,*) timeinc
C Read if data domain is periodic and its periodicity
read(9,*) per
c Read the number of trajectories and name of position file
read(9,*) strname
read(9,*) ntra
read(9,*) ncol
if (ntra.eq.0) goto 991
C Read the name of the output trajectory file and set the constants file
read(9,*) cdfname
C Read the timestep for trajectory calculation (convert from minutes to hours)
read(9,*) ts
ts=ts/60.
C Read shift of start and end time relative to first data file
read(9,*) tst
read(9,*) ten
C Read output time interval (in minutes)
read(9,*) deltout
C Read jumpflag (if =1 ground-touching trajectories reenter the atmosphere)
read(9,*) jflag
C Read factor for vertical velocity field
read(9,*) wfactor
c Read the reference time and the time range
read(9,*) reftime(1) ! year
read(9,*) reftime(2) ! month
read(9,*) reftime(3) ! day
read(9,*) reftime(4) ! hour
read(9,*) reftime(5) ! min
read(9,*) reftime(6) ! time range (in min)
c Read flag for 'no time check'
read(9,*) timecheck
c Close the input file
close(9)
c Calculate the number of output time steps
ntim = abs(reftime(6)/deltout) + 1
c Set the formats of the input and output files
call mode_tra(inpmode,strname)
call mode_tra(outmode,cdfname)
if (outmode.eq.-1) outmode=1
c Write some status information
print*,'---- INPUT PARAMETERS -----------------------------------'
print*
print*,' Forward/Backward : ',fbflag
print*,' #input files : ',numdat
print*,' First/last input file : ',trim(dat(1)),' ... ',
> trim(dat(numdat))
print*,' time increment : ',timeinc
print*,' Output file : ',trim(cdfname)
print*,' Time step (min) : ',60.*ts
write(*,'(a27,f7.2,f7.2)') ' Time shift (start,end) : ',tst,ten
print*,' Output time interval : ',deltout
print*,' Jump flag : ',jflag
print*,' Vertical wind (scale) : ',wfactor
print*,' Trajectory pos file : ',trim(strname)
print*,' # of trajectories : ',ntra
print*,' # of output timesteps : ',ntim
if ( inpmode.eq.-1) then
print*,' Input format : (lon,lat,p)-list'
else
print*,' Input format : ',inpmode
endif
print*,' Output format : ',outmode
print*,' Periodicity : ',per
print*,' Time check : ',trim(timecheck)
print*
print*,'---- FIXED NUMERICAL PARAMETERS -------------------------'
print*
print*,' Numerical scheme : ',imethod
print*,' Number of iterations : ',numit
print*,' Filename prefix : ',prefix
print*,' Missing data value : ',mdv
print*
c --------------------------------------------------------------------
c Read grid parameters, checks and allocate memory
c --------------------------------------------------------------------
c Read the constant grid parameters (nx,ny,nz,xmin,xmax,ymin,ymax,pollon,pollat)
c The negative <-fid> of the file identifier is used as a flag for parameter retrieval
filename = prefix//dat(1)
varname = 'U'
nx = 1
ny = 1
nz = 1
tload = -tst
call input_open (fid,filename)
call input_grid (-fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,rd,rd,nz,rd,rd,rd,timecheck)
call input_close(fid)
C Check if the number of levels is too large
if (nz.gt.nlevmax) goto 993
C Set logical flag for periodic data set (hemispheric or not)
hem = 0
if (per.eq.0.) then
delta=xmax-xmin-360.
if (abs(delta+dx).lt.eps) then ! Program aborts: arrays must be closed
goto 992
else if (abs(delta).lt.eps) then ! Periodic and hemispheric
hem=1
per=360.
endif
else ! Periodic and hemispheric
hem=1
endif
C Allocate memory for some meteorological arrays
allocate(spt0(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt0 ***' ! Surface pressure
allocate(spt1(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt1 ***'
allocate(uut0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array uut0 ***' ! Zonal wind
allocate(uut1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array uut1 ***'
allocate(vvt0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array vvt0 ***' ! Meridional wind
allocate(vvt1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array vvt1 ***'
allocate(wwt0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array wwt0 ***' ! Vertical wind
allocate(wwt1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array wwt1 ***'
allocate(p3t0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t0 ***' ! Pressure
allocate(p3t1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
C Get memory for trajectory arrays
allocate(trainp(ntra,1,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp ***' ! Input start coordinates
allocate(traout(ntra,ntim,4),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traout ***' ! Output trajectories
allocate(xx0(ntra),stat=stat)
if (stat.ne.0) print*,'*** error allocating array xx0 ***' ! X position (longitude)
allocate(yy0(ntra),stat=stat)
if (stat.ne.0) print*,'*** error allocating array yy0 ***' ! Y position (latitude)
allocate(pp0(ntra),stat=stat)
if (stat.ne.0) print*,'*** error allocating array pp0 ***' ! Pressure
allocate(leftflag(ntra),stat=stat)
if (stat.ne.0) print*,'*** error allocating array leftflag ***' ! Leaving-domain flag
c Write some status information
print*,'---- CONSTANT GRID PARAMETERS ---------------------------'
print*
print*,' xmin,xmax : ',xmin,xmax
print*,' ymin,ymax : ',ymin,ymax
print*,' dx,dy : ',dx,dy
print*,' pollon,pollat : ',pollon,pollat
print*,' nx,ny,nz : ',nx,ny,nz
print*,' per, hem : ',per,hem
print*
c --------------------------------------------------------------------
c Initialize the trajectory calculation
c --------------------------------------------------------------------
c Read start coordinates from file - Format (lon,lat,lev)
if (inpmode.eq.-1) then
open(fid,file=strname)
do i=1,ntra
read(fid,*) xx0(i),yy0(i),pp0(i)
enddo
close(fid)
c Read start coordinates from trajectory file - check consistency of ref time
else
call ropen_tra(cdfid,strname,ntra,1,ncol,reftmp,vars,inpmode)
call read_tra (cdfid,trainp,ntra,1,ncol,inpmode)
do i=1,ntra
time = trainp(i,1,1)
xx0(i) = trainp(i,1,2)
yy0(i) = trainp(i,1,3)
pp0(i) = trainp(i,1,4)
enddo
call close_tra(cdfid,inpmode)
if ( ( reftime(1).ne.reftmp(1) ).or.
> ( reftime(2).ne.reftmp(2) ).or.
> ( reftime(3).ne.reftmp(3) ).or.
> ( reftime(4).ne.reftmp(4) ).or.
> ( reftime(5).ne.reftmp(5) ) )
> then
print*,' WARNING: Inconsistent reference times'
write(*,'(5i8)') (reftime(i),i=1,5)
write(*,'(5i8)') (reftmp (i),i=1,5)
print*,'Enter a key to proceed...'
stop
endif
endif
c Set sign of time range
reftime(6) = fbflag * reftime(6)
c Write some status information
print*,'---- REFERENCE DATE---------- ---------------------------'
print*
print*,' Reference time (year) :',reftime(1)
print*,' (month) :',reftime(2)
print*,' (day) :',reftime(3)
print*,' (hour) :',reftime(4)
print*,' (min) :',reftime(5)
print*,' Time range :',reftime(6),' min'
print*
C Save starting positions
itim = 1
do i=1,ntra
traout(i,itim,1) = 0.
traout(i,itim,2) = xx0(i)
traout(i,itim,3) = yy0(i)
traout(i,itim,4) = pp0(i)
enddo
c Init the flag and the counter for trajectories leaving the domain
leftcount=0
do i=1,ntra
leftflag(i)=0
enddo
C Convert time shifts <tst,ten> from <hh.mm> into fractional time
call hhmm2frac(tst,frac)
tst = frac
call hhmm2frac(ten,frac)
ten = frac
c Check that all starting positions are above topography
varname = 'P'
filename = prefix//dat(1)
call input_open (fid,filename)
call input_grid
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz,timecheck)
call input_close(fid)
do i=1,ntra
C Interpolate surface pressure to actual position (from first input file)
x1 = xx0(i)
y1 = yy0(i)
call get_index4 (xind,yind,pind,x1,y1,1050.,0.,
> p3t1,p3t1,spt1,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
sp = int_index4 (spt1,spt1,nx,ny,1,xind,yind,1.,0.,mdv)
c Decide whether to keep the trajectory
if ( pp0(i).gt.sp ) then
write(*,'(a30,4f10.2)')
> 'WARNING: starting point below topography ',
> xx0(i),yy0(i),pp0(i),sp
leftflag(i) = 1
endif
enddo
c -----------------------------------------------------------------------
c Loop to calculate trajectories
c -----------------------------------------------------------------------
c Write some status information
print*
print*,'---- TRAJECTORIES ----------- ---------------------------'
print*
C Set the time for the first data file (depending on forward/backward mode)
if (fbflag.eq.1) then
tstart = -tst
else
tstart = tst
endif
c Set the minute counter for output
wstep = 0
c Read wind fields and vertical grid from first file
filename = prefix//dat(1)
call frac2hhmm(tstart,tload)
write(*,'(a16,a20,f7.2)') ' (file,time) : ',
> trim(filename),tload
call input_open (fid,filename)
varname='U' ! U
call input_wind
> (fid,varname,uut1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
varname='V' ! V
call input_wind
> (fid,varname,vvt1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
varname='OMEGA' ! OMEGA
call input_wind
> (fid,varname,wwt1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid ! GRID
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz,timecheck)
call input_close(fid)
c Loop over all input files (time step is <timeinc>)
do itm=1,numdat-1
c Calculate actual and next time
time0 = tstart+real(itm-1)*timeinc*fbflag
time1 = time0+timeinc*fbflag
c Copy old velocities and pressure fields to new ones
do i=1,nx*ny*nz
uut0(i)=uut1(i)
vvt0(i)=vvt1(i)
wwt0(i)=wwt1(i)
p3t0(i)=p3t1(i)
enddo
do i=1,nx*ny
spt0(i)=spt1(i)
enddo
c Read wind fields and surface pressure at next time
filename = prefix//dat(itm+1)
call frac2hhmm(time1,tload)
write(*,'(a16,a20,f7.2)') ' (file,time) : ',
> trim(filename),tload
call input_open (fid,filename)
varname='U' ! U
call input_wind
> (fid,varname,uut1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
varname='V' ! V
call input_wind
> (fid,varname,vvt1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
varname='OMEGA' ! OMEGA
call input_wind
> (fid,varname,wwt1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid ! GRID
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz,timecheck)
call input_close(fid)
C Determine the first and last loop indices
if (numdat.eq.2) then
filo = nint(tst/ts)+1
lalo = nint((timeinc-ten)/ts)
elseif ( itm.eq.1 ) then
filo = nint(tst/ts)+1
lalo = nint(timeinc/ts)
else if (itm.eq.numdat-1) then
filo = 1
lalo = nint((timeinc-ten)/ts)
else
filo = 1
lalo = nint(timeinc/ts)
endif
c Split the interval <timeinc> into computational time steps <ts>
do iloop=filo,lalo
C Calculate relative time position in the interval timeinc (0=beginning, 1=end)
reltpos0 = ((real(iloop)-1.)*ts)/timeinc
reltpos1 = real(iloop)*ts/timeinc
c Timestep for all trajectories
do i=1,ntra
C Check if trajectory has already left the data domain
if (leftflag(i).ne.1) then
c Iterative Euler timestep (x0,y0,p0 -> x1,y1,p1)
if (imethod.eq.1) then
call euler(
> xx1,yy1,pp1,leftflag(i),
> xx0(i),yy0(i),pp0(i),reltpos0,reltpos1,
> ts*3600,numit,jflag,mdv,wfactor,fbflag,
> spt0,spt1,p3t0,p3t1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
> xmin,ymin,dx,dy,per,hem,nx,ny,nz)
c Runge-Kutta timestep (x0,y0,p0 -> x1,y1,p1)
else if (imethod.eq.2) then
call runge(
> xx1,yy1,pp1,leftflag(i),
> xx0(i),yy0(i),pp0(i),reltpos0,reltpos1,
> ts*3600,numit,jflag,mdv,wfactor,fbflag,
> spt0,spt1,p3t0,p3t1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
> xmin,ymin,dx,dy,per,hem,nx,ny,nz)
endif
c Update trajectory position, or increase number of trajectories leaving domain
if (leftflag(i).eq.1) then
leftcount=leftcount+1
if ( leftcount.lt.10 ) then
print*,' -> Trajectory ',i,' leaves domain'
elseif ( leftcount.eq.10 ) then
print*,' -> N>=10 trajectories leave domain'
endif
else
xx0(i)=xx1
yy0(i)=yy1
pp0(i)=pp1
endif
c Trajectory has already left data domain (mark as <mdv>)
else
xx0(i)=mdv
yy0(i)=mdv
pp0(i)=mdv
endif
enddo
C Save positions only every deltout minutes
delta = aint(iloop*60*ts/deltout)-iloop*60*ts/deltout
if (abs(delta).lt.eps) then
c wstep = wstep + abs(ts)
c if ( mod(wstep,deltout).eq.0 ) then
time = time0+reltpos1*timeinc*fbflag
itim = itim + 1
do i=1,ntra
call frac2hhmm(time,tload)
traout(i,itim,1) = tload
traout(i,itim,2) = xx0(i)
traout(i,itim,3) = yy0(i)
traout(i,itim,4) = pp0(i)
enddo
endif
enddo
enddo
c Write trajectory file
vars(1) ='time'
vars(2) ='lon'
vars(3) ='lat'
vars(4) ='p'
call wopen_tra(cdfid,cdfname,ntra,ntim,4,reftime,vars,outmode)
call write_tra(cdfid,traout,ntra,ntim,4,outmode)
call close_tra(cdfid,outmode)
c Write some status information, and end of program message
print*
print*,'---- STATUS INFORMATION --------------------------------'
print*
print*,' #leaving domain ', leftcount
print*,' #staying in domain ', ntra-leftcount
print*
print*,' *** END OF PROGRAM CALTRA ***'
print*,'========================================================='
stop
c ------------------------------------------------------------------
c Exception handling
c ------------------------------------------------------------------
991 write(*,*) '*** ERROR: all start points outside the data domain'
call exit(1)
992 write(*,*) '*** ERROR: close arrays on files (prog. closear)'
call exit(1)
993 write(*,*) '*** ERROR: problems with array size'
call exit(1)
end
c *******************************************************************
c * Time step : either Euler or Runge-Kutta *
c *******************************************************************
C Time-step from (x0,y0,p0) to (x1,y1,p1)
C
C (x0,y0,p0) input coordinates (long,lat,p) for starting point
C (x1,y1,p1) output coordinates (long,lat,p) for end point
C deltat input timestep in seconds
C numit input number of iterations
C jump input flag (=1 trajectories don't enter the ground)
C left output flag (=1 if trajectory leaves data domain)
c -------------------------------------------------------------------
c Iterative Euler time step
c -------------------------------------------------------------------
subroutine euler(x1,y1,p1,left,x0,y0,p0,reltpos0,reltpos1,
> deltat,numit,jump,mdv,wfactor,fbflag,
> spt0,spt1,p3d0,p3d1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
> xmin,ymin,dx,dy,per,hem,nx,ny,nz)
implicit none
c Declaration of subroutine parameters
integer nx,ny,nz
real x1,y1,p1
integer left
real x0,y0,p0
real reltpos0,reltpos1
real deltat
integer numit
integer jump
real wfactor
integer fbflag
real spt0(nx*ny) ,spt1(nx*ny)
real uut0(nx*ny*nz),uut1(nx*ny*nz)
real vvt0(nx*ny*nz),vvt1(nx*ny*nz)
real wwt0(nx*ny*nz),wwt1(nx*ny*nz)
real p3d0(nx*ny*nz),p3d1(nx*ny*nz)
real xmin,ymin,dx,dy
real per
integer hem
real mdv
c Numerical and physical constants
real deltay
parameter (deltay=1.112E5) ! Distance in m between 2 lat circles
real pi
parameter (pi=3.1415927) ! Pi
c Auxiliary variables
real xmax,ymax
real xind,yind,pind
real u0,v0,w0,u1,v1,w1,u,v,w,sp
integer icount
character ch
c Externals
real int_index4
external int_index4
c Reset the flag for domain-leaving
left=0
c Set the esat-north bounray of the domain
xmax = xmin+real(nx-1)*dx
ymax = ymin+real(ny-1)*dy
C Interpolate wind fields to starting position (x0,y0,p0)
call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0,
> p3d0,p3d1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
u0 = int_index4(uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
v0 = int_index4(vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
w0 = int_index4(wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
c Force the near-surface wind to zero
if (pind.lt.1.) w0=w0*pind
C For first iteration take ending position equal to starting position
x1=x0
y1=y0
p1=p0
C Iterative calculation of new position
do icount=1,numit
C Calculate new winds for advection
call get_index4 (xind,yind,pind,x1,y1,p1,reltpos1,
> p3d0,p3d1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
u1 = int_index4(uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)
v1 = int_index4(vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)
w1 = int_index4(wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)
c Force the near-surface wind to zero
if (pind.lt.1.) w1=w1*pind
c Get the new velocity in between
u=(u0+u1)/2.
v=(v0+v1)/2.
w=(w0+w1)/2.
C Calculate new positions
x1 = x0 + fbflag*u*deltat/(deltay*cos(y0*pi/180.))
y1 = y0 + fbflag*v*deltat/deltay
p1 = p0 + fbflag*wfactor*w*deltat/100.
c Handle pole problems (crossing and near pole trajectory)
if ((hem.eq.1).and.(y1.gt.90.)) then
y1=180.-y1
x1=x1+per/2.
endif
if ((hem.eq.1).and.(y1.lt.-90.)) then
y1=-180.-y1
x1=x1+per/2.
endif
if (y1.gt.89.99) then
y1=89.99
endif
c Handle crossings of the dateline
if ((hem.eq.1).and.(x1.gt.xmin+per-dx)) then
x1=xmin+amod(x1-xmin,per)
endif
if ((hem.eq.1).and.(x1.lt.xmin)) then
x1=xmin+per+amod(x1-xmin,per)
endif
C Interpolate surface pressure to actual position
call get_index4 (xind,yind,pind,x1,y1,1050.,reltpos1,
> p3d0,p3d1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
sp = int_index4 (spt0,spt1,nx,ny,1,xind,yind,1.,reltpos1,mdv)
c Handle trajectories which cross the lower boundary (jump flag)
if ((jump.eq.1).and.(p1.gt.sp)) p1=sp-10.
C Check if trajectory leaves data domain
if ( ( (hem.eq.0).and.(x1.lt.xmin) ).or.
> ( (hem.eq.0).and.(x1.gt.xmax-dx) ).or.
> (y1.lt.ymin).or.(y1.gt.ymax).or.(p1.gt.sp) )
> then
left=1
goto 100
endif
enddo
c Exit point for subroutine
100 continue
return
end
c -------------------------------------------------------------------
c Runge-Kutta (4th order) time-step
c -------------------------------------------------------------------
subroutine runge(x1,y1,p1,left,x0,y0,p0,reltpos0,reltpos1,
> deltat,numit,jump,mdv,wfactor,fbflag,
> spt0,spt1,p3d0,p3d1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
> xmin,ymin,dx,dy,per,hem,nx,ny,nz)
implicit none
c Declaration of subroutine parameters
integer nx,ny,nz
real x1,y1,p1
integer left
real x0,y0,p0
real reltpos0,reltpos1
real deltat
integer numit
integer jump
real wfactor
integer fbflag
real spt0(nx*ny) ,spt1(nx*ny)
real uut0(nx*ny*nz),uut1(nx*ny*nz)
real vvt0(nx*ny*nz),vvt1(nx*ny*nz)
real wwt0(nx*ny*nz),wwt1(nx*ny*nz)
real p3d0(nx*ny*nz),p3d1(nx*ny*nz)
real xmin,ymin,dx,dy
real per
integer hem
real mdv
c Numerical and physical constants
real deltay
parameter (deltay=1.112E5) ! Distance in m between 2 lat circles
real pi
parameter (pi=3.1415927) ! Pi
c Auxiliary variables
real xmax,ymax
real xind,yind,pind
real u0,v0,w0,u1,v1,w1,u,v,w,sp
integer icount,n
real xs,ys,ps,xk(4),yk(4),pk(4)
real reltpos
c Externals
real int_index4
external int_index4
c Reset the flag for domain-leaving
left=0
c Set the esat-north bounray of the domain
xmax = xmin+real(nx-1)*dx
ymax = ymin+real(ny-1)*dy
c Apply the Runge Kutta scheme
do n=1,4
c Get intermediate position and relative time
if (n.eq.1) then
xs=0.
ys=0.
ps=0.
reltpos=reltpos0
else if (n.eq.4) then
xs=xk(3)
ys=yk(3)
ps=pk(3)
reltpos=reltpos1
else
xs=xk(n-1)/2.
ys=yk(n-1)/2.
ps=pk(n-1)/2.
reltpos=(reltpos0+reltpos1)/2.
endif
C Calculate new winds for advection
call get_index4 (xind,yind,pind,x0+xs,y0+ys,p0+ps,reltpos,
> p3d0,p3d1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
u = int_index4 (uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos,mdv)
v = int_index4 (vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos,mdv)
w = int_index4 (wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos,mdv)
c Force the near-surface wind to zero
if (pind.lt.1.) w1=w1*pind
c Update position and keep them
xk(n)=fbflag*u*deltat/(deltay*cos(y0*pi/180.))
yk(n)=fbflag*v*deltat/deltay
pk(n)=fbflag*w*deltat*wfactor/100.
enddo
C Calculate new positions
x1=x0+(1./6.)*(xk(1)+2.*xk(2)+2.*xk(3)+xk(4))
y1=y0+(1./6.)*(yk(1)+2.*yk(2)+2.*yk(3)+yk(4))
p1=p0+(1./6.)*(pk(1)+2.*pk(2)+2.*pk(3)+pk(4))
c Handle pole problems (crossing and near pole trajectory)
if ((hem.eq.1).and.(y1.gt.90.)) then
y1=180.-y1
x1=x1+per/2.
endif
if ((hem.eq.1).and.(y1.lt.-90.)) then
y1=-180.-y1
x1=x1+per/2.
endif
if (y1.gt.89.99) then
y1=89.99
endif
c Handle crossings of the dateline
if ((hem.eq.1).and.(x1.gt.xmin+per-dx)) then
x1=xmin+amod(x1-xmin,per)
endif
if ((hem.eq.1).and.(x1.lt.xmin)) then
x1=xmin+per+amod(x1-xmin,per)
endif
C Interpolate surface pressure to actual position
call get_index4 (xind,yind,pind,x1,y1,1050.,reltpos1,
> p3d0,p3d1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
sp = int_index4 (spt0,spt1,nx,ny,1,xind,yind,1,reltpos,mdv)
c Handle trajectories which cross the lower boundary (jump flag)
if ((jump.eq.1).and.(p1.gt.sp)) p1=sp-10.
C Check if trajectory leaves data domain
if ( ( (hem.eq.0).and.(x1.lt.xmin) ).or.
> ( (hem.eq.0).and.(x1.gt.xmax-dx) ).or.
> (y1.lt.ymin).or.(y1.gt.ymax).or.(p1.gt.sp) )
>then
left=1
goto 100
endif
c Exit point fdor subroutine
100 continue
return
end

/tags/1.0/caltra/caltra.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = caltra.o ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/ioinp.a ${LAGRANTO}/lib/inter.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
caltra: $(OBJS)
${F77} -o caltra $(OBJS) ${INCS} $(LIBS)

/tags/1.0/caltra/caltra.sh
0,0 → 1,601
#!/bin/csh
# ---------------------------------------------------------------------
# Usage, parameter settings
# ---------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( (${#argv} == 0) | (${#argv} < 4) ) then
echo
${LAGRANTO}/bin/lagrantohelp caltra short
echo
exit 0
endif
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR CALTRA *** '
echo
# Get the arguments
set startdate = $1
set enddate = $2
set startf = $3
set outfile = $4
if ( ${#argv} > 4 ) then
set flags = $5
else
set flags=
endif
# Set base directories (run+prog)
set cdfdir=${PWD}
set tradir=${PWD}
# Set program paths and filenames
set parfile = ${tradir}/caltra.param
# Set the prefix of the primary and secondary data files
set charp = 'P'
set chars = 'S'
echo '---- DIRECTORIES AND PROGRAMS ---------------------------'
echo
echo "CDF directory : ${cdfdir}"
echo "TRA directory : ${tradir}"
echo "PROGRAM CALTRA : ${LAGRANTO}/caltra/caltra"
echo "PARAMETER file : ${parfile}"
echo
# ---------------------------------------------------------------------
# Set optional flags
# ---------------------------------------------------------------------
echo '---- OPTIONAL FLAGS -------------------------------------'
echo
# Set some default values ("nil" must be set according to input files)
set flag_j = "nil"
set flag_i = "nil"
set flag_t = "nil"
set flag_o = "nil"
set flag_p = "nil"
set changet = 'false'
set noclean = 'false'
set timecheck = 'no'
while ( $#argv > 0 )
switch ( $argv[1] )
case -j
set flag_j=1
echo "Flag '-j' -> ${flag_j} (user defined)"
breaksw
case -i
set flag_i=$argv[2]
echo "Flag '-i' -> ${flag_i} (user defined)"
shift;
breaksw
case -t
set flag_t=$argv[2]
echo "Flag '-t' -> ${flag_t} (user defined)"
shift;
breaksw
case -o
set flag_o=$argv[2]
echo "Flag '-o' -> ${flag_o} (user defined)"
shift;
breaksw
case -p
set flag_p=1
echo "Flag '-p' -> ${flag_p} (user defined)"
breaksw
case -changet
set changet = 'true'
echo "changet -> true (user defined)"
breaksw
case -noclean
set noclean = 'true'
echo "noclean -> true (user defined)"
breaksw
case -timecheck
set timecheck = 'yes'
echo "timecheck -> yes (user defined)"
breaksw
endsw
shift;
end
# No change of times necessary if no check requested
if ( "${timecheck}" == "no" ) then
set changet = 'false'
endif
# Set some defaults
if ( "${flag_j}" == "nil" ) then
set flag_j = 0
echo "Flag '-j' -> 0 (default)"
endif
if ( "${flag_p}" == "nil" ) then
set flag_p = 0
echo "Flag '-p' -> 0 (default)"
endif
# ---------------------------------------------------------------------
# Handle the time specifier - startdate, enddate
# ---------------------------------------------------------------------
echo
echo '---- TIME RANGE -----------------------------------------'
echo
# Check format of start and end date - must be the same
set ns=`echo $startdate | sed -e 's/_[0-9]*//' | wc -c`
set ne=`echo $enddate | sed -e 's/_[0-9]*//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( $ns != 9 ) then
echo " ERROR: Date format must be yyyymmdd ***"
exit 1
endif
set ns=`echo $startdate | sed -e 's/[0-9]*_//' | wc -c`
set ne=`echo $enddate | sed -e 's/[0-9]*_//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( ( $ns != 5 ) & ( $ns != 3 ) ) then
echo " ERROR: Time format must be hh(mm) ***"
exit 1
endif
# Split the start and end date into <yymmdd_hh and mm>
set startdate_ymdh = `echo $startdate | cut -c 1-11`
set startdate_min = `echo $startdate | cut -c 12-13`
if ( $startdate_min == "" ) set startdate_min = 00
set enddate_ymdh = `echo $enddate | cut -c 1-11`
set enddate_min = `echo $enddate | cut -c 12-13`
if ( $enddate_min == "" ) set enddate_min = 00
# Get the time difference between <start_ymdh> and <end_ymdh> date
# Decide whether trajectoriesare forward or backward
set timediff_hh = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${startdate_ymdh}`
if ( $timediff_hh == 0 ) then
if ( $enddate_min > $startdate_min ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
endif
else if ( $timediff_hh > 0 ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
@ timediff_hh = $idir * $timediff_hh
endif
# Get also minutes for time difference, if <start_min> or <end_min> != 0
set timediff_mm=
if ( $startdate_min != 00 || $enddate_min != 00 ) then
@ min = ( $enddate_min - $startdate_min )
if ( $min == 0 ) then
set timediff_mm=
else if ( $min > 0 ) then
if ( $idir == 1 ) then
set timediff_mm=$min
else
@ timediff_hh --
@ timediff_mm = 60 - $min
endif
else
if ( $idir == 1 ) then
@ timediff_hh --
@ timediff_mm = 60 + $min
else
@ timediff_mm = 0 - $min
endif
endif
endif
# Set the reference date equal to the satrtdate
set refdate=${startdate}
# Write status information
echo "Time range : ${startdate} -> ${enddate}"
if ( ${timediff_mm} != "" ) then
echo "Time difference : ${timediff_hh} h ${timediff_mm} min"
else
echo "Time difference : ${timediff_hh} h"
endif
echo "Direction : ${direction} (${idir})"
echo "Reference date : ${refdate}"
# ---------------------------------------------------------------------
# Check availability of input data
# ---------------------------------------------------------------------
echo
echo '---- INPUT FILES ----------------------------------------'
echo
# Take the time increment from flag list ('nil', if not defined)
set timeinc = ${flag_i}
# Find a first data file (if possible corresponding to start/end date
# If starttime is not a data time, take the first file in the direectory
if ( $direction == "f" ) then
set file=${charp}${startdate_ymdh}
else
set file=${charp}${enddate_ymdh}
endif
if ( ! -f $file ) then
set file=`ls ${charp}[0-9_]*[0-9] | head -1 | sed -e 's/@//'`
endif
# Determine timeinc (the time difference in hours between two data file)
# if not already defined with option -i
if ( ${timeinc} == "nil" ) then
set date1=`echo $file | cut -c 2-12`
set n=`ls ${charp}[0-9_]*[0-9] | grep -n $date1 | awk -F: '{print $1}'`
@ n ++
set date2=`ls ${charp}[0-9_]*[0-9] | head -$n | tail -1 | cut -c 2-12`
set timeinc=`${LAGRANTO}/goodies/gettidiff $date2 $date1`
endif
if ( $timeinc == 0 ) then
echo " ERROR: cannot set the time increment between input files ***"
exit 1
endif
# Search the first file to use: We step through all P files and see whether they are
# good P files. Let's first do the test for the first data file found. If it's ok, we
# take it; if not, we step through all P files and find the good one
set flag=0
set td=
set date = `echo $file | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
foreach i ( ${charp}????????_?? )
set date = `echo $i | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
end
# if no P/T-files are available for the specified time period, then $td is
# still undefined
if ( $td == "" ) then
echo " ERROR: no data files available for the specified time period"
exit 1
endif
# Everything is fine so far: proceed
label2:
# Check whether first date is ok - before or at needed dates
if ( $direction == "f" ) then
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
else
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
endif
if ( $tdiff0 < 0 ) then
echo " ERROR: data files missing for the specified time period"
exit 1
endif
# Calculate the number of further files
@ num = ( $timediff_hh + $td ) / $timeinc + 1
@ dum1 = ( $num - 1 ) * $timeinc
@ dum2 = $timediff_hh + $td
if ( $dum1 != $dum2 ) @ num ++
# Get a list of all needed files
set numfiles=$num
set sfiles=1
echo $datfiles
while ( $num > 1 )
set date=`${LAGRANTO}/goodies/newtime $date $timeinc`
echo $date
if ( ! -f ${charp}${date} ) then
echo " ERROR: file with primary data is missing for $date"
exit 1
else if ( ! -f ${chars}${date} ) then
set sfiles=0
set datfiles=`echo $datfiles $date`
else
set datfiles=`echo $datfiles $date`
endif
@ num --
end
# Write some status information
echo "Primary file prefix : ${charp}"
echo "Secondary file prefix : ${chars}"
echo "Time increment for input files : ${timeinc}"
echo "# input files : ${numfiles}"
echo "${charp} files availability : 1"
echo "${chars} files availability : ${sfiles}"
echo "First input file : $datfiles[1] "
echo "Last input file : $datfiles[$numfiles] "
# ---------------------------------------------------------------------
# Handle vertical wind - scaling factor
# ---------------------------------------------------------------------
echo
echo '---- VERTICAL WIND SCALING ------------------------------'
echo
set wfactor=1.
# Write status information
echo "Vertical scaling factor (wfactor) : ${wfactor}"
# ---------------------------------------------------------------------
# Time step and output interval
# ---------------------------------------------------------------------
echo
echo '---- TIME STEPS -----------------------------------------'
echo
# Take the time step and output step from flag list ('nil', if not defined)
set timestep = ${flag_t}
set deltout = ${flag_o}
# Calculate the time step
if ( $timestep == "nil" ) @ timestep = ( 60 * $timeinc ) / 12
# Take the output interval from time increment
if ( $deltout == "nil" ) @ deltout = 60 * ${timeinc}
# Check whether the timestep is an integer ratio of deltout
@ flag = $deltout / $timestep
@ flag = $deltout - ( $flag * $timestep )
if ( $flag != 0 ) then
echo " ERROR: output time interval should be multiple of timestep"
echo
echo " $deltout min : output time interval"
echo " $timestep min : time step"
exit 1
endif
# Calculate the start and the end time relative to the first datfile
if ( $direction == f ) then
set tstart = `${LAGRANTO}/goodies/gettidiff $startdate $datfiles[1]`
set tend = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $enddate`
else
set tstart = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $startdate`
set tend = `${LAGRANTO}/goodies/gettidiff $enddate $datfiles[1]`
endif
# Check whether tstart and tend are a multiple of the output time interval
if ( $tstart != 0 ) then
if ( `echo $tstart | grep "\."` != "" ) then
set dum=`echo $tstart | sed -e 's/[-0-9]*\.//'`
@ flag = $dum / $deltout
@ flag = $dum - ( $flag * $deltout )
if ( $flag != 0 ) then
echo " ERROR : the start time should be shifted relative to the first"
echo " datafile by a multiple of the output time interval"
echo " hint: set the latter with the option -o"
exit 1
endif
endif
endif
if ( `echo $tend | grep "\."` != "" ) then
set dum=`echo $tend | sed -e 's/[-0-9]*\.//'`
@ flag = $dum / $deltout
@ flag = $dum - ( $flag * $deltout )
if ( $flag != 0 ) then
echo " ERROR : the end time should be shifted relative to the first"
echo " datafile by a multiple of the output time interval"
echo " hint: set the latter with the option -o"
exit 1
endif
endif
# Write status information
echo "Trajectory calculation time step [min] : ${timestep}"
echo "Output time step [min] : ${deltout}"
if ( $direction == f ) then
echo "Start time relative to first file : $datfiles[1] + ${tstart} "
echo "End time relative to first file : $datfiles[$numfiles] - ${tend} "
else
echo "Start time relative to first file : $datfiles[$numfiles] - ${tstart} "
echo "End time relative to last file : $datfiles[1] + ${tend} "
endif
# ---------------------------------------------------------------------
# Start file
# ---------------------------------------------------------------------
echo
echo '---- START FILE -----------------------------------------'
echo
# Check if start file is available
if ( ! -f ${startf} ) then
echo " ERROR : start file ${startf} is missing"
exit 1
endif
# Decide whether startfile has an explicit format specifier
set format = "0"
foreach app ( 1 2 3 4 5 6 7 8 9 )
set flag = `echo ${startf} | grep "\.${app}"`
if ( "${flag}" != "" ) set format = "${app}"
end
# If format is 0, it might nevertheless be a hidden format 1
if ( "${format}" == "0" ) then
set ncol = `awk "{print NF}" ${startf} | tail -1`
if ( "${ncol}" != "3" ) then
set format = "1"
echo " WARNING: ${startf} is a hidden trajectory file of format 1"
echo " it will be renamed: ${startf} -> ${startf}.1"
echo
ln -sf ${startf} ${startf}.1
set startf = "${startf}.1"
endif
endif
# Get the number of trajectories
if ( "${format}" == "0" ) then
set ntra = `wc -l ${startf} | awk '{print $1}' `
set ncol = 3
else
set ntra = `${LAGRANTO}/goodies/trainfo.sh ${startf} ntra`
set ncol = `${LAGRANTO}/goodies/trainfo.sh ${startf} ncol`
set ntim = `${LAGRANTO}/goodies/trainfo.sh ${startf} ntim`
if ( "${ntim}" != "1" ) then
echo " ERROR: starting trajectory file must only have one time... Stop"
exit 1
endif
endif
# Write status information
echo "Start file : ${startf} "
if ( "${format}" == "0" ) then
echo "Format : (lon,lat,p) list"
else
echo "Format : trajectory file (${format})"
endif
echo "# coordinates (lon,lat,lev) : ${ntra} "
echo "# columns : ${ncol} "
# ---------------------------------------------------------------------
# Prepare input file for caltra and run it
# ---------------------------------------------------------------------
# Set times relative to the reference date
if ( "${changet}" == "true" ) then
echo
echo '---- CHANGE TIMES ON DATA FILES ------------------------'
echo
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${charp}${i}
end
if ( ${sfiles} == 1 ) then
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${chars}${i}
end
endif
endif
# Split the reference date
set yyyy=`echo ${refdate} | cut -c 1-4`
set mm=`echo ${refdate} | cut -c 5-6`
set dd=`echo ${refdate} | cut -c 7-8`
set hh=`echo ${refdate} | cut -c 10-11`
set min=`echo ${refdate}00 | cut -c 12-13`
# Get the total tiem range
if ( ${timediff_mm} != '' ) then
@ timerange = 60 * ${timediff_hh} + ${timediff_mm}
else
@ timerange = 60 * ${timediff_hh}
endif
# Write parameter file
\rm -f ${parfile}
touch ${parfile}
\echo $idir >> $parfile
echo $numfiles >> $parfile
foreach i ( $datfiles )
echo $i >> $parfile
end
echo $timeinc >> $parfile
echo $flag_p >> $parfile
echo \"${startf}\" >> $parfile
echo ${ntra} >> $parfile
echo ${ncol} >> $parfile
echo \"${outfile}\" >> $parfile
echo $timestep >> $parfile
echo $tstart >> $parfile
echo $tend >> $parfile
echo $deltout >> $parfile
echo $flag_j >> $parfile
echo $wfactor >> $parfile
echo $yyyy >> $parfile
echo $mm >> $parfile
echo $dd >> $parfile
echo $hh >> $parfile
echo $min >> $parfile
echo $timerange >> $parfile
echo \"${timecheck}\" >> $parfile
# Finish the preprocessor
echo
echo ' *** END OF PREPROCESSOR CALTRA *** '
echo '========================================================='
echo
# Run caltra
${LAGRANTO}/caltra/caltra
if ( "${status}" != "0" ) then
echo "ERROR: Program <caltra> failed"
exit 1
endif
# ----------------------------------------------------------
# Final tasks (make clean)
# ----------------------------------------------------------
finish:
if ( "${noclean}" == "false" ) then
\rm -f ${parfile}
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/create_startf/create_startf.f
0,0 → 1,1735
PROGRAM create_startf
c **************************************************************
c * Create a <startfile> for <lagrangto>. It can be chosen *
c * whether to start from an isentropic or an isobaric *
c * surface. The starting points are equidistantly distributed *
c * Michael Sprenger / Autumn 2004 *
c **************************************************************
implicit none
c --------------------------------------------------------------
c Set parameters
c --------------------------------------------------------------
c Maximum number of starting positions
integer nmax
parameter (nmax=1000000)
c Maximum number of model levels
integer nlevmax
parameter (nlevmax=200)
c Grid constant (distance in km corresponding to 1 deg at the equator)
real deltat
parameter (deltat=111.)
c Mathematical constant (conversion degree -> radian)
real pi180
parameter (pi180=3.14159/180.)
c Numerical epsilon
real eps
parameter (eps=0.00001)
c --------------------------------------------------------------
c Set variables
c --------------------------------------------------------------
c Filenames and output format
character*80 pfile0,pfile1 ! P filenames
character*80 sfile0,sfile1 ! S filenames
character*80 ofile ! Output filename
integer oformat ! Output format
real timeshift ! Time shift relative to data files <*0>
real timeinc ! Time increment between input files
c Horizontal grid
character*80 hmode ! Horizontale mode
real lat1,lat2,lon1,lon2 ! Lat/lon boundaries
real ds,dlon,dlat ! Distance and lat/lon shifts
character*80 hfile ! Filename
integer hn ! Number of entries in lat/lon list
real latlist(nmax) ! List of latitudes
real lonlist(nmax) ! List of longitudes
integer pn ! Number of entries in lat/lon poly
real latpoly(500) ! List of polygon latitudes
real lonpoly(500) ! List of polygon longitudes
real loninpoly,latinpoly ! Lon/lat inside polygon
character*80 regionf ! Region file
integer iregion ! Region number
real xcorner(4),ycorner(4) ! Vertices of region
c Vertical grid
character*80 vmode ! Vertical mode
real lev1,lev2,levlist(nmax) ! Single levels, and list of levels
character*80 vfile ! Filename
integer vn ! Number of entries
c Unit of vertical axis
character*80 umode ! Unit of vertical axis
c Flag for 'no time check'
character*80 timecheck ! Either 'no' or 'yes'
c List of all starting positions
integer start_n ! Number of coordinates
real start_lat(nmax) ! Latitudes
real start_lon(nmax) ! Longitudes
real start_lev(nmax) ! Levels (depending on vertical unit)
real start_pre(nmax) ! Level in hPa
integer reftime(6) ! Reference time
character*80 vars(10) ! Name of output fields (time,lon,lat,p)
real,allocatable, dimension (:,:,:) :: tra ! Trajectories (ntra,ntim,ncol)
real latmin,latmax
real lonmin,lonmax
real premin,premax
c Grid description
real pollon,pollat ! Longitude/latitude of pole
real ak(nlevmax) ! Vertical layers and levels
real bk(nlevmax)
real xmin,xmax ! Zonal grid extension
real ymin,ymax ! Meridional grid extension
integer nx,ny,nz ! Grid dimensions
real dx,dy ! Horizontal grid resolution
real,allocatable, dimension (:,:,:) :: pr ! 3d pressure
real,allocatable, dimension (:,:) :: prs ! surface pressure
real,allocatable, dimension (:,:,:) :: th ! 3d potential temperature
real,allocatable, dimension (:,:) :: ths ! surface poential temperature
real,allocatable, dimension (:,:,:) :: pv ! 3d potential vorticity
real,allocatable, dimension (:,:) :: pvs ! surface potential vorticiy
real,allocatable, dimension (:,:,:) :: in ! 3d 'dummy' array with vertical indices
character*80 varname ! Name of input variable
integer fid ! File identifier
real stagz ! Vertical staggering
real mdv ! Missing data values
real tstart,tend ! Time on P and S file
real rid,rjd,rkd ! Real grid position
c Auxiliary variable
integer i,j,k
real lon,lat
real rd
integer stat,flag
real tmp1,tmp2
real tfrac,frac
real radius,dist
character*80 string
character*80 selectstr
character*80 umode_save
real,allocatable, dimension (:,:,:) :: fld0
real,allocatable, dimension (:,:,:) :: fld1
real,allocatable, dimension (:,: ) :: sfc0
real,allocatable, dimension (:,:) :: sfc1
c Externals
real int_index3 ! 3d interpolation
external int_index3
real sdis ! Speherical distance
external sdis
integer inregion ! In/out of region
external inrehion
c ------------------------------------------------------------------
c Start of program, Read parameters
c ------------------------------------------------------------------
c Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM CREATE_STARTF ***'
print*
c Read parameter file
open(10,file='create_startf.param')
c Input P and S file
read(10,*) pfile0,pfile1
read(10,*) sfile0,sfile1
read(10,*) ofile
c Read name of region file
read(10,*) regionf
c Reference time
do i=1,6
read(10,*) reftime(i)
enddo
c Time shift relative to data files <pfile0,sfile0> - format (hh.mm)
read(10,*) timeshift
c Read timeincrement between input files
read(10,*) timeinc
c Parameters for horizontal grid
read(10,*) hmode
if ( hmode.eq.'file' ) then ! from file
read(10,*) hfile
elseif ( hmode.eq.'line' ) then ! along a line
read(10,*) lon1,lon2,lat1,lat2,hn
elseif ( hmode.eq.'box.eqd' ) then ! box: 2d equidistant
read(10,*) lon1,lon2,lat1,lat2,ds
elseif ( hmode.eq.'box.grid' ) then ! box: 2d grid
read(10,*) lon1,lon2,lat1,lat2
elseif ( hmode.eq.'point' ) then ! single point
read(10,*) lon1,lat1
elseif ( hmode.eq.'shift' ) then ! centre + shifted
read(10,*) lon1,lat1,dlon,dlat
elseif ( hmode.eq.'polygon.eqd' ) then ! polygon: 2d equidistant
read(10,*) hfile,ds
elseif ( hmode.eq.'polygon.grid' ) then ! polygon: 2d grid
read(10,*) hfile
elseif ( hmode.eq.'circle.eqd' ) then ! circle: 2d equidistant
read(10,*) lon1,lat1,radius,ds
elseif ( hmode.eq.'circle.grid' ) then ! circle: 2d grid
read(10,*) lon1,lat1,radius
elseif ( hmode.eq.'region.eqd' ) then ! region: 2d equidistant
read(10,*) iregion,ds
elseif ( hmode.eq.'region.grid' ) then ! iregion: 2d grid
read(10,*) iregion
else
print*,' ERROR: horizontal mode not supported ',trim(hmode)
stop
endif
c Parameters for vertical grid
read(10,*) vmode
if ( vmode.eq.'file') then ! from file
read(10,*) vfile
elseif ( vmode.eq.'level' ) then ! single level (explicit command)
read(10,*) lev1
elseif ( vmode.eq.'list') then ! a list
read(10,*) vn
read(10,*) (levlist(i),i=1,vn)
elseif ( vmode.eq.'profile') then ! a profile
read(10,*) lev1,lev2,vn
elseif ( vmode.eq.'grid') then ! grid points
read(10,*) lev1,lev2
else
print*,' ERROR: vertical mode not supported ',trim(vmode)
stop
endif
c Read units of vertical axis
read(10,*) umode
if ( ( umode.ne.'hPa' ).and.
> ( umode.ne.'hPa,agl' ).and.
> ( umode.ne.'K' ).and.
> ( umode.ne.'PVU' ).and.
> ( umode.ne.'INDEX' ) )
> then
print*,' ERROR: unit not supported ',trim(umode)
stop
endif
c Read selection criterion (dummy read)
read(10,*) selectstr
c Read flag for 'no time check'
read(10,*) timecheck
c Close parameter file
close(10)
c Decide which output format is used (1..4: trajectory format, -1: triple list)
call mode_tra(oformat,ofile)
c Decide whether all lat/lon/lev coordaintes are read from one file
if ( (hmode.eq.'file').and.(vmode.eq.'nil') ) then
hmode='file3'
elseif ( (hmode.eq.'file').and.(vmode.ne.'nil') ) then
hmode='file2'
endif
c Convert timeshift (hh.mm) into a fractional time shift
call hhmm2frac(timeshift,tfrac)
if (tfrac.gt.0.) then
tfrac=tfrac/timeinc
else
tfrac=0.
endif
c Read the region coordinates if needed
if ( (hmode.eq.'region.eqd' ).or.
> (hmode.eq.'region.grid') ) then
open(10,file=regionf)
50 read(10,*,end=51) string
if ( string(1:1).ne.'#' ) then
call regionsplit(string,i,xcorner,ycorner)
if ( i.eq.iregion ) goto 52
endif
goto 50
51 close(10)
print*,' ERROR: region ',iregion,' not found on ',trim(regionf)
stop
52 continue
endif
c Write some status information
print*,'---- INPUT PARAMETERS -----------------------------------'
print*
if ( timeshift.gt.0. ) then
print*,' P file : ',trim(pfile0),
> ' ',
> trim(pfile1)
print*,' S file : ',trim(sfile0),
> ' ',
> trim(sfile1)
else
print*,' P file : ',trim(pfile0)
print*,' S file : ',trim(sfile0)
endif
print*,' Output file : ',trim(ofile)
print*
if (oformat.eq.-1) then
print*,' Output format : (lon,lat,lev)-list'
else
print*,' Output format : ',oformat
endif
print*
print*,' Reference time (year) : ',reftime(1)
print*,' (month) : ',reftime(2)
print*,' (day) : ',reftime(3)
print*,' (hour) : ',reftime(4)
print*,' (min) : ',reftime(5)
print*,' Time range : ',reftime(6)
print*
print*,' Time shift : ',timeshift,' + ',
> trim(pfile0)
print*,' Region file : ',trim(regionf)
print*
print*,' hmode : ',trim(hmode)
if ( hmode.eq.'file2' ) then
print*,' filename [lat/lon] : ',trim(hfile)
elseif ( hmode.eq.'file3' ) then
print*,' filename [lat/lon/lev] : ',trim(hfile)
elseif ( hmode.eq.'line' ) then
write(*,'(a30,4f10.2,i4)')
> ' lon1,lon2,lat1,lat2,n : ',lon1,lon2,lat1,lat2,hn
elseif ( hmode.eq.'box.eqd' ) then
write(*,'(a30,5f10.2)')
> ' lon1,lon2,lat1,lat2,ds : ',lon1,lon2,lat1,lat2,ds
elseif ( hmode.eq.'box.grid' ) then
write(*,'(a30,4f10.2)')
> ' lon1,lon2,lat1,lat2 : ',lon1,lon2,lat1,lat2
elseif ( hmode.eq.'point' ) then
print*,' lon,lat : ',lon1,lat1
elseif ( hmode.eq.'shift' ) then
write(*,'(a30,4f10.2)')
> ' lon,lat,dlon,dlat : ',lon1,lat1,dlon,dlat
elseif ( hmode.eq.'polygon.eqd' ) then
write(*,'(a30,a10,f10.2)')
> ' hfile, ds : ',trim(hfile),ds
elseif ( hmode.eq.'polygon.grid' ) then
write(*,'(a30,a10)')
> ' hfile : ',trim(hfile)
elseif ( hmode.eq.'circle.eqd' ) then
write(*,'(a30,4f10.2)')
> ' lonc,latc,radius, ds : ',lon1,lat1,radius,ds
elseif ( hmode.eq.'circle.grid' ) then
write(*,'(a30,3f10.2)')
> ' lonc,latc,radius : ',lon1,lat1,radius
elseif ( hmode.eq.'region.eqd' ) then
write(*,'(a30,i4,1f10.2)')
> ' iregion, ds : ',iregion,ds
write(*,'(a30,4f10.2)')
> ' xcorner : ',(xcorner(i),i=1,4)
write(*,'(a30,4f10.2)')
> ' ycorner : ',(ycorner(i),i=1,4)
elseif ( hmode.eq.'region.grid' ) then
write(*,'(a30,i4)')
> ' iregion : ',iregion
write(*,'(a30,4f10.2)')
> ' xcorner : ',(xcorner(i),i=1,4)
write(*,'(a30,4f10.2)')
> ' ycorner : ',(ycorner(i),i=1,4)
endif
print*
print*,' vmode : ',trim(vmode)
if ( vmode.eq.'file') then
print*,' filename : ',trim(vfile)
elseif ( vmode.eq.'level' ) then
print*,' level : ',lev1
elseif ( vmode.eq.'list') then
print*,' n : ',vn
print*,' level(i) : ',(levlist(i),i=1,vn)
elseif ( vmode.eq.'profile') then
print*,' lev1,lev2,n : ',lev1,lev2,vn
elseif ( vmode.eq.'grid') then
print*,' lev1,lev2 : ',lev1,lev2
endif
print*
print*,' umode : ',trim(umode)
print*
print*,' time check : ',trim(timecheck)
print*
c ------------------------------------------------------------------
c Read grid parameters from inital files
c ------------------------------------------------------------------
c Get the time of the first and second data file
tstart = -timeshift ! Format hh.mm
call hhmm2frac(tstart,frac)
frac = frac + timeinc
call frac2hhmm(frac,tend) ! Format hh.mm
c Convert timeshift (hh.mm) into a fractional time shift
tfrac=real(int(timeshift))+
> 100.*(timeshift-real(int(timeshift)))/60.
if (tfrac.gt.0.) then
tfrac=tfrac/timeinc
else
tfrac=0.
endif
c Read the constant grid parameters (nx,ny,nz,xmin,xmax,ymin,ymax,
c pollon,pollat) The negative <-fid> of the file identifier is used
c as a flag for parameter retrieval
varname = 'U'
nx = 1
ny = 1
nz = 1
call input_open (fid,pfile0)
call input_grid (-fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tstart,pollon,pollat,rd,rd,nz,rd,rd,rd,timecheck)
call input_close(fid)
c Check whether region coordinates are within the domain
if ( (hmode.eq.'region.eqd' ).or.
> (hmode.eq.'region.grid') ) then
do i=1,4
if ( (xcorner(i).lt.xmin).or.
> (ycorner(i).lt.ymin).or.
> (xcorner(i).gt.xmax).or.
> (ycorner(i).gt.ymax) )
> then
print*,' ERROR: region not included in data domain...'
print*,' ',trim(string)
print*,' ',(xcorner(j),j=1,4)
print*,' ',(ycorner(j),j=1,4)
stop
endif
enddo
endif
C Check if the number of levels is too large
if (nz.gt.nlevmax) goto 993
c Allocate memory for 3d arrays: pressure, theta, pv
allocate(pr(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array pr ***'
allocate(prs(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array prs **'
allocate(th(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array th ***'
allocate(ths(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array ths **'
allocate(pv(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array pv ***'
allocate(pvs(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array pvs **'
allocate(in(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array in ***'
c Allocate memory for temporary arrays for time interpolation
allocate(fld0(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tmp0 ***'
allocate(fld1(nx,ny,nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tmp1 ***'
allocate(sfc0(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array sfc0 ***'
allocate(sfc1(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array sfc1 ***'
c ------ Index -----------------------------------------------------
c Init the dummy array with vertical index
do i=1,nx
do j=1,ny
do k=1,nz
in(i,j,k) = real(k)
enddo
enddo
enddo
c ------ Pressure --------------------------------------------------
c Read pressure from first data file (pfile0) on U-grid; we have to set
c mdv explicitely, because it's not read from netCDF
call input_open (fid,pfile0)
varname='U'
call input_grid
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tstart,pollon,pollat,fld0,sfc0,nz,ak,bk,stagz,timecheck)
mdv = -999.99
call input_close(fid)
c Read or set pressure for second data file (pfile1)
if ( timeshift.ne.0.) then
call input_open (fid,pfile1)
varname='U'
call input_grid
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tend,pollon,pollat,fld1,sfc1,nz,ak,bk,stagz,timecheck)
call input_close(fid)
else
do i=1,nx
do j=1,ny
do k=1,nz
fld1(i,j,k) = fld0(i,j,k)
enddo
sfc1(i,j) = sfc0(i,j)
enddo
enddo
endif
c Time interpolation to get the final pressure field
do i=1,nx
do j=1,ny
do k=1,nz
pr(i,j,k) = (1.-tfrac) * fld0(i,j,k) +
> tfrac * fld1(i,j,k)
enddo
prs(i,j) = (1.-tfrac) * sfc0(i,j) +
> tfrac * sfc1(i,j)
enddo
enddo
c ------ Potential temperature -------------------------------------
if ( (umode.eq.'K').or.(umode.eq.'PVU') ) then
c Read potential temperature from first data file <sfile0>
call input_open (fid,sfile0)
varname='TH' ! Theta
call input_wind
> (fid,varname,fld0,tstart,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_close(fid)
c Read or set potential temperature for second data file (sfile1)
if ( timeshift.ne.0.) then
call input_open (fid,sfile1)
varname='TH'
call input_wind
> (fid,varname,fld1,tend,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_close(fid)
else
do i=1,nx
do j=1,ny
do k=1,nz
fld1(i,j,k) = fld0(i,j,k)
enddo
enddo
enddo
endif
c Time interpolation to get the final potential temperature field
do i=1,nx
do j=1,ny
do k=1,nz
th(i,j,k) = (1.-tfrac) * fld0(i,j,k) +
> tfrac * fld1(i,j,k)
enddo
enddo
enddo
c Set the surface potential temperature
do i=1,nx
do j=1,ny
ths(i,j)=th(i,j,1)
enddo
enddo
endif
c ------ Potential vorticity -----------------------------------------
if ( (umode.eq.'PVU') ) then
c Read potential vorticity from first data file <sfile0>
call input_open (fid,sfile0)
varname='PV'
call input_wind
> (fid,varname,fld0,tstart,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_close(fid)
c Read or set potential vorticity for second data file (sfile1)
if ( timeshift.ne.0.) then
call input_open (fid,sfile1)
varname='PV'
call input_wind
> (fid,varname,fld1,tend,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_close(fid)
else
do i=1,nx
do j=1,ny
do k=1,nz
fld1(i,j,k) = fld0(i,j,k)
enddo
enddo
enddo
endif
c Time interpolation to get the final potential vorticity field
do i=1,nx
do j=1,ny
do k=1,nz
pv(i,j,k) = (1.-tfrac) * fld0(i,j,k) +
> tfrac * fld1(i,j,k)
enddo
enddo
enddo
c Set the surface potential vorticity
do i=1,nx
do j=1,ny
pvs(i,j)=pv(i,j,1)
enddo
enddo
endif
c Write some status information
print*,'---- CONSTANT GRID PARAMETERS ---------------------------'
print*
print*,' xmin,xmax : ',xmin,xmax
print*,' ymin,ymax : ',ymin,ymax
print*,' dx,dy : ',dx,dy
print*,' pollon,pollat : ',pollon,pollat
print*,' nx,ny,nz : ',nx,ny,nz
print*
print*,' Pressure loaded : ',trim(pfile0),' ',trim(pfile1)
if ( (umode.eq.'K').or.(umode.eq.'PVU') ) then
print*,' Theta loaded : ',trim(sfile0),' ',trim(sfile1)
endif
if ( (umode.eq.'PVU') ) then
print*,' PV loaded : ',trim(sfile0),' ',trim(sfile1)
endif
print*
c ------------------------------------------------------------------
c Determine the expanded list of starting coordinates
c ------------------------------------------------------------------
c Write some status information
print*,'---- EXPAND LIST OF STARTING POSITIONS -----------------'
print*
c ------ Read lat/lon/lev from <hfile> -----------------------------
if ( hmode.eq.'file3' ) then
start_n = 0
open(10,file=hfile)
100 continue
start_n = start_n + 1
read(10,*,end=101) start_lon(start_n),
> start_lat(start_n),
> start_lev(start_n)
goto 100
101 continue
start_n = start_n - 1
close(10)
goto 400
endif
c ------ Get lat/lon (horizontal) coordinates ---------------------
c Read lat/lon from <hfile>
if ( hmode.eq.'file2' ) then
hn = 0
open(10,file=hfile)
200 continue
hn = hn + 1
read(10,*,end=201) lonlist(hn),
> latlist(hn)
goto 200
201 continue
hn = hn - 1
close(10)
endif
c Get lat/lon along a line (linear in lat/lon space)
if ( hmode.eq.'line' ) then
do i=1,hn
lonlist(i) = lon1 + real(i-1)/real(hn-1)*(lon2-lon1)
latlist(i) = lat1 + real(i-1)/real(hn-1)*(lat2-lat1)
enddo
endif
c Lat/lon box: equidistant
if ( hmode.eq.'box.eqd' ) then
hn = 0
lat = lat1
do while ( lat.le.lat2 )
lon = lon1
do while ( lon.le.lon2 )
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
lon = lon+ds/(deltat*cos(pi180*lat))
enddo
lat = lat+ds/deltat
enddo
endif
c Lat/lon box: grid
if ( hmode.eq.'box.grid' ) then
hn = 0
do j=1,ny
do i=1,nx
lon = xmin + real(i-1) * dx
lat = ymin + real(j-1) * dy
if ( (lon.ge.lon1).and.(lon.le.lon2).and.
> (lat.ge.lat1).and.(lat.le.lat2) )
> then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
enddo
enddo
endif
c Get single starting point
if ( hmode.eq.'point' ) then
hn = 1
lonlist(hn) = lon1
latlist(hn) = lat1
endif
c Get shifted and central starting point
if ( hmode.eq.'shift' ) then
hn = 5
lonlist(1) = lon1
latlist(1) = lat1
lonlist(2) = lon1+dlon
latlist(2) = lat1
lonlist(3) = lon1-dlon
latlist(3) = lat1
lonlist(4) = lon1
latlist(4) = lat1+dlat
lonlist(5) = lon1
latlist(5) = lat1-dlat
endif
c Lat/lon polygon: grid
if ( hmode.eq.'polygon.grid' ) then
c Read list of polygon coordinates
pn = 0
open(10,file=hfile)
read(10,*) loninpoly,latinpoly
210 continue
pn = pn + 1
read(10,*,end=211) lonpoly(pn),
> latpoly(pn)
print*,pn,lonpoly(pn),latpoly(pn)
goto 210
211 continue
pn = pn - 1
close(10)
c Define the polygon boundaries
call DefSPolyBndry(latpoly,lonpoly,pn,latinpoly,loninpoly)
c Get the grid points inside the polygon
hn = 0
do j=1,ny
do i=1,nx
lon = xmin + real(i-1) * dx
lat = ymin + real(j-1) * dy
call LctPtRelBndry(lat,lon,flag)
if ( (flag.eq.1).or.(flag.eq.2) ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
enddo
enddo
endif
c Lat/lon polygon: equidistant
if ( hmode.eq.'polygon.eqd' ) then
c Read list of polygon coordinates
pn = 0
open(10,file=hfile)
read(10,*) loninpoly,latinpoly
220 continue
pn = pn + 1
read(10,*,end=221) lonpoly(pn),
> latpoly(pn)
goto 220
221 continue
pn = pn - 1
close(10)
c Define the polygon boundaries
call DefSPolyBndry(latpoly,lonpoly,pn,latinpoly,loninpoly)
c Get the grid points inside the polygon
hn = 0
lat = -90.
do while ( lat.le.90. )
lon = -180.
do while ( lon.lt.180. )
call LctPtRelBndry(lat,lon,flag)
if ( (flag.eq.1).or.(flag.eq.2) ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
lon = lon+ds/(deltat*cos(pi180*lat))
enddo
lat = lat+ds/deltat
enddo
endif
c Circle: equidistant
if ( hmode.eq.'circle.eqd' ) then
hn = 0
lat = ymin
do while ( lat.le.ymax )
lon = xmin
do while ( lon.le.xmax )
dist = sdis(lon1,lat1,lon,lat)
if ( dist.le.radius ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
lon = lon+ds/(deltat*cos(pi180*lat))
enddo
lat = lat+ds/deltat
enddo
endif
c Circle: grid
if ( hmode.eq.'circle.grid' ) then
hn = 0
do j=1,ny
do i=1,nx
lon = xmin + real(i-1) * dx
lat = ymin + real(j-1) * dy
dist = sdis(lon1,lat1,lon,lat)
if ( dist.le.radius ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
enddo
enddo
endif
c Region: equidistant
if ( hmode.eq.'region.eqd' ) then
hn = 0
lat = ymin
do while ( lat.le.ymax )
lon = xmin
do while ( lon.le.xmax )
flag = inregion(lon,lat,xcorner,ycorner)
if ( flag.eq.1 ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
lon = lon+ds/(deltat*cos(pi180*lat))
enddo
lat = lat+ds/deltat
enddo
endif
c Region: grid
if ( hmode.eq.'region.grid' ) then
hn = 0
do j=1,ny
do i=1,nx
lon = xmin + real(i-1) * dx
lat = ymin + real(j-1) * dy
flag = inregion(lon,lat,xcorner,ycorner)
if ( flag.eq.1 ) then
hn = hn+1
lonlist(hn) = lon
latlist(hn) = lat
endif
enddo
enddo
endif
c ------ Get lev (vertical) coordinates -------------------------
c Read level list from file
if ( vmode.eq.'file' ) then
vn = 0
open(10,file=vfile)
300 continue
vn = vn + 1
read(10,*,end=301) levlist(vn)
goto 300
301 continue
vn = vn - 1
close(10)
endif
c Get single starting level
if ( vmode.eq.'level' ) then
vn = 1
levlist(vn) = lev1
endif
c Get level profile
if ( vmode.eq.'profile' ) then
do i=1,vn
levlist(i) = lev1 + real(i-1)/real(vn-1)*(lev2-lev1)
enddo
endif
c Get all grid points in a layer: at the moment set the list of levels to
c all indices from 1 to nz; later the correct subset of indices will be chosen
if ( vmode.eq.'grid' ) then
vn = nz
do i=1,vn
levlist(i) = real(i)
enddo
umode_save = umode
umode = 'INDEX'
endif
c ------ Compile the complete list of starting positions ------
c Get all starting points in specified vertical coordinate system
start_n = 0
do i=1,vn
do j=1,hn
start_n = start_n + 1
start_lon(start_n) = lonlist(j)
start_lat(start_n) = latlist(j)
start_lev(start_n) = levlist(i)
enddo
enddo
c ------ Exit point of this section
400 continue
c Write status information
print*,' # expanded points : ', start_n
print*
c ------------------------------------------------------------------
c Transform starting levels into pressure
c ------------------------------------------------------------------
c Write some status information
print*,'---- STARTING POSITIONS ---------------------------------'
print*
c Vertical mode <hPa,asl> or simply <hPa>
if ( (umode.eq.'hPa,asl').or.(umode.eq.'hPa') ) then
do i=1,start_n
start_pre(i) = start_lev(i)
enddo
c Vertical mode <hPa,agl>
elseif ( umode.eq.'hPa,agl' ) then
do i=1,start_n
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),1050.,
> 3,pr,prs,nx,ny,nz,xmin,ymin,dx,dy)
tmp1 = int_index3 (prs,nx,ny,1,rid,rjd,1,mdv)
start_pre(i) = tmp1 - start_lev(i)
enddo
c Vertical mode <K>
elseif ( umode.eq.'K' ) then
do i=1,start_n
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_lev(i),1,th,ths,nx,ny,nz,xmin,ymin,dx,dy)
tmp1 = int_index3 (pr,nx,ny,nz,rid,rjd,rkd,mdv)
start_pre(i) = tmp1
enddo
c Vertical mode <PVU>
elseif ( umode.eq.'PVU' ) then
do i=1,start_n
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_lev(i),2,pv,pvs,nx,ny,nz,xmin,ymin,dx,dy)
tmp1 = int_index3 (pr,nx,ny,nz,rid,rjd,rkd,mdv)
start_pre(i) = tmp1
enddo
c Vertical mode <INDEX>
elseif ( umode.eq.'INDEX' ) then
do i=1,start_n
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> 1050.,2,pv,pvs,nx,ny,nz,xmin,ymin,dx,dy)
rkd = start_lev(i)
tmp1 = int_index3 (pr,nx,ny,nz,rid,rjd,rkd,mdv)
start_pre(i) = tmp1
enddo
endif
c ------------------------------------------------------------------
c Remove invalid points from the list
c ------------------------------------------------------------------
c Select the correct subset if <vmode=grid>: starting points outside the layer
c will receive a <mdv> vertical pressure and will be removed
if ( vmode.eq.'grid' ) then
do i=1,start_n
c Get the pressure at the grid point
if ( ( umode_save.eq.'hPa' ).or.
> (umode_save.eq.'hPa,asl') )
> then
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_pre(i),3,pr,prs,nx,ny,nz,xmin,
> ymin,dx,dy)
tmp1 = int_index3 (pr,nx,ny,nz,rid,rjd,rkd,mdv)
c Get pressure AGL at grid point
elseif ( umode_save.eq.'hPa,agl' ) then
call get_index3(rid,rjd,rkd,start_lon(i),
> start_lat(i),start_pre(i),3,pr,prs,
> nx,ny,nz,xmin,ymin,dx,dy)
tmp1 = int_index3 (pr,nx,ny,nz,rid,rjd,rkd,mdv)
call get_index3(rid,rjd,rkd,start_lon(i),
> start_lat(i),1050.,3,pr,prs,nx,ny,
> nz,xmin,ymin,dx,dy)
tmp2 = int_index3 (prs,nx,ny,1,rid,rjd,1,mdv)
tmp1 = tmp2 - tmp1
c Get potential temperature at grid point
elseif ( umode_save.eq.'K' ) then
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_pre(i),3,pr,prs,nx,ny,nz,
> xmin,ymin,dx,dy)
tmp1 = int_index3 (th,nx,ny,nz,rid,rjd,rkd,mdv)
c Get potential vorticity at the grid point
elseif ( umode_save.eq.'PVU' ) then
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_pre(i),3,pr,prs,nx,ny,nz,xmin,
> ymin,dx,dy)
tmp1 = int_index3 (pv,nx,ny,nz,rid,rjd,rkd,mdv)
c Get vertical index at the grid point
elseif ( umode_save.eq.'INDEX' ) then
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),
> start_pre(i),3,pr,prs,nx,ny,nz,
> xmin,ymin,dx,dy)
tmp1 = int_index3 (in,nx,ny,nz,rid,rjd,rkd,mdv)
endif
c Remove points outside layer
if ( ( tmp1.lt.lev1).or.(tmp1.gt.lev2) ) then
start_pre(i) = mdv
endif
enddo
endif
c Check whether the starting levels are valid (in data domain)
do i=1,start_n
call get_index3(rid,rjd,rkd,start_lon(i),start_lat(i),1050.,
> 3,pr,prs,nx,ny,nz,xmin,ymin,dx,dy)
tmp1 = int_index3 (prs,nx,ny, 1,rid,rjd,real( 1),mdv) ! Surface
tmp2 = int_index3 (pr ,nx,ny,nz,rid,rjd,real(nz),mdv) ! Top of domain
if ( (start_pre(i).gt.tmp1).or.
> (start_pre(i).lt.tmp2).or.
> (start_lon(i).lt.xmin).or.
> (start_lon(i).gt.xmax).or.
> (start_lat(i).lt.ymin).or.
> (start_lat(i).gt.ymax) )
> then
start_pre(i) = mdv
endif
enddo
c Remove all starting points outside the domain
i = 1
do while ( i.le.start_n )
if ( abs(start_pre(i)-mdv).lt.eps ) then
if ( vmode.ne.'grid') then
print*,' Outside ', start_lon(i),start_lat(i),start_lev(i)
endif
do j=i,start_n
start_lon(j) = start_lon(j+1)
start_lat(j) = start_lat(j+1)
start_pre(j) = start_pre(j+1)
start_lev(j) = start_lev(j+1)
enddo
start_n = start_n - 1
else
i = i + 1
endif
enddo
c Write some status information
latmin = start_lat(1)
latmax = start_lat(1)
lonmin = start_lon(1)
lonmax = start_lon(1)
premin = start_pre(1)
premax = start_pre(1)
do i=1,start_n
if (start_lat(i).lt.latmin) latmin = start_lat(i)
if (start_lat(i).gt.latmax) latmax = start_lat(i)
if (start_lon(i).lt.lonmin) lonmin = start_lon(i)
if (start_lon(i).gt.lonmax) lonmax = start_lon(i)
if (start_pre(i).lt.premin) premin = start_pre(i)
if (start_pre(i).gt.premax) premax = start_pre(i)
enddo
print*,' min(lat),max(lat) : ', latmin,latmax
print*,' min(lon),max(lon) : ', lonmin,lonmax
print*,' min(pre),max(pre) : ', premin,premax
print*
print*,' # starting points : ', start_n
print*
c ------------------------------------------------------------------
c Write starting positions to output file
c ------------------------------------------------------------------
c Output as a trajectory file (with only one time == 0)
if (oformat.ne.-1) then
allocate(tra(start_n,1,5),stat=stat)
vars(1) ='time'
vars(2) ='lon'
vars(3) ='lat'
vars(4) ='p'
vars(5) ='level'
call wopen_tra(fid,ofile,start_n,1,5,reftime,vars,oformat)
do i=1,start_n
tra(i,1,1) = 0.
tra(i,1,2) = start_lon(i)
tra(i,1,3) = start_lat(i)
tra(i,1,4) = start_pre(i)
tra(i,1,5) = start_lev(i)
enddo
call write_tra(fid,tra,start_n,1,5,oformat)
call close_tra(fid,oformat)
c Output as a triple list (corresponding to <startf> file)
else
fid = 10
open(fid,file=ofile)
do i=1,start_n
write(fid,'(3f10.3)') start_lon(i),start_lat(i),
> start_pre(i)
enddo
close(fid)
endif
c Write some status information, and end of program message
print*
print*,'---- STATUS INFORMATION --------------------------------'
print*
print*,'ok'
print*
print*,' *** END OF PROGRAM CREATE_STARTF ***'
print*,'========================================================='
c ------------------------------------------------------------------
c Exception handling
c ------------------------------------------------------------------
stop
993 write(*,*) '*** ERROR: problems with array size'
call exit(1)
end
c --------------------------------------------------------------------------
c Split a region string and get corners of the domain
c --------------------------------------------------------------------------
subroutine regionsplit(string,iregion,xcorner,ycorner)
c The region string comes either as <lonw,lone,lats,latn> or as <lon1,lat1,
c lon2,lat2,lon3,lat3,lon4,lat4>: split it into ints components and get the
c four coordinates for the region
implicit none
c Declaration of subroutine parameters
character*80 string
real xcorner(4),ycorner(4)
integer iregion
c Local variables
integer i,n
integer il,ir
real subfloat (80)
integer stat
integer len
c ------- Split the string
i = 1
n = 0
stat = 0
il = 1
len = len_trim(string)
100 continue
c Find start of a substring
do while ( stat.eq.0 )
if ( string(i:i).ne.' ' ) then
stat = 1
il = i
else
i = i + 1
endif
enddo
c Find end of substring
do while ( stat.eq.1 )
if ( ( string(i:i).eq.' ' ) .or. ( i.eq.len ) ) then
stat = 2
ir = i
else
i = i + 1
endif
enddo
c Convert the substring into a number
if ( stat.eq.2 ) then
n = n + 1
read(string(il:ir),*) subfloat(n)
stat = 0
endif
if ( i.lt.len ) goto 100
c -------- Get the region number
iregion = nint(subfloat(1))
c -------- Get the corners of the region
if ( n.eq.5 ) then ! lonw(2),lone(3),lats(4),latn(5)
xcorner(1) = subfloat(2)
ycorner(1) = subfloat(4)
xcorner(2) = subfloat(3)
ycorner(2) = subfloat(4)
xcorner(3) = subfloat(3)
ycorner(3) = subfloat(5)
xcorner(4) = subfloat(2)
ycorner(4) = subfloat(5)
elseif ( n.eq.9 ) then ! lon1,lat1,lon2,lat2,lon3,lon4,lat4
xcorner(1) = subfloat(2)
ycorner(1) = subfloat(3)
xcorner(2) = subfloat(4)
ycorner(2) = subfloat(5)
xcorner(3) = subfloat(6)
ycorner(3) = subfloat(7)
xcorner(4) = subfloat(8)
ycorner(4) = subfloat(9)
else
print*,' ERROR: invalid region specification '
print*,' ',trim(string)
stop
endif
end
c --------------------------------------------------------------------------
c Decide whether lat/lon point is in or out of region
c --------------------------------------------------------------------------
integer function inregion (lon,lat,xcorner,ycorner)
c Decide whether point (lon/lat) is in the region specified by <xcorner(1..4),
c ycorner(1..4).
implicit none
c Declaration of subroutine parameters
real lon,lat
real xcorner(4),ycorner(4)
c Local variables
integer flag
real xmin,xmax,ymin,ymax
integer i
c Reset the flag
flag = 0
c Set some boundaries
xmax = xcorner(1)
xmin = xcorner(1)
ymax = ycorner(1)
ymin = ycorner(1)
do i=2,4
if (xcorner(i).lt.xmin) xmin = xcorner(i)
if (xcorner(i).gt.xmax) xmax = xcorner(i)
if (ycorner(i).lt.ymin) ymin = ycorner(i)
if (ycorner(i).gt.ymax) ymax = ycorner(i)
enddo
c Do the tests - set flag=1 if all tests pased
if (lon.lt.xmin) goto 970
if (lon.gt.xmax) goto 970
if (lat.lt.ymin) goto 970
if (lat.gt.ymax) goto 970
if ((lon-xcorner(1))*(ycorner(2)-ycorner(1))-
> (lat-ycorner(1))*(xcorner(2)-xcorner(1)).gt.0.) goto 970
if ((lon-xcorner(2))*(ycorner(3)-ycorner(2))-
> (lat-ycorner(2))*(xcorner(3)-xcorner(2)).gt.0.) goto 970
if ((lon-xcorner(3))*(ycorner(4)-ycorner(3))-
> (lat-ycorner(3))*(xcorner(4)-xcorner(3)).gt.0.) goto 970
if ((lon-xcorner(4))*(ycorner(1)-ycorner(4))-
> (lat-ycorner(4))*(xcorner(1)-xcorner(4)).gt.0.) goto 970
flag = 1
c Return the value
970 continue
inregion = flag
return
end
c --------------------------------------------------------------------------
c Spherical distance between lat/lon points
c --------------------------------------------------------------------------
real function sdis(xp,yp,xq,yq)
c
c calculates spherical distance (in km) between two points given
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
c
real re
parameter (re=6370.)
real pi180
parameter (pi180=3.14159/180.)
real xp,yp,xq,yq,arg
arg=sin(pi180*yp)*sin(pi180*yq)+
> cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
if (arg.lt.-1.) arg=-1.
if (arg.gt.1.) arg=1.
sdis=re*acos(arg)
end
c ****************************************************************
c * Given some spherical polygon S and some point X known to be *
c * located inside S, these routines will determine if an arbit- *
c * -rary point P lies inside S, outside S, or on its boundary. *
c * The calling program must first call DefSPolyBndry to define *
c * the boundary of S and the point X. Any subsequent call to *
c * subroutine LctPtRelBndry will determine if some point P lies *
c * inside or outside S, or on its boundary. (Usually *
c * DefSPolyBndry is called once, then LctPrRelBndry is called *
c * many times). *
c * *
c * REFERENCE: Bevis, M. and Chatelain, J.-L. (1989) *
c * Maflaematical Geology, vol 21. *
c * VERSION 1.0 *
c ****************************************************************
Subroutine DefSPolyBndry(vlat,vlon,nv,xlat, xlon)
c ****************************************************************
c * This mmn entry point is used m define ~e spheric~ polygon S *
c * and the point X. *
c * ARGUMENTS: *
c * vlat,vlon (sent) ... vectors containing the latitude and *
c * longitude of each vertex of the *
c * spherical polygon S. The ith.vertex is *
c * located at [vlat(i),vlon(i)]. *
c * nv (sent) ... the number of vertices and sides in the *
c * spherical polygon S *
c * xlat,xlon (sent) ... latitude and longitude of some point X *
c * located inside S. X must not be located *
c * on any great circle that includes two *
c * vertices of S. *
c * *
c * UNITS AND SIGN CONVENTION: *
c * Latitudes and longitudes are specified in degrees. *
c * Latitudes are positive to the north and negative to the *
c * south. *
c * Longitudes are positive to the east and negative to the *
c * west. *
c * *
c * VERTEX ENUMERATION: *
c * The vertices of S should be numbered sequentially around the *
c * border of the spherical polygon. Vertex 1 lies between vertex*
c * nv and vertex 2. Neighbouring vertices must be seperated by *
c * less than 180 degrees. (In order to generate a polygon side *
c * whose arc length equals or exceeds 180 degrees simply *
c * introduce an additional (pseudo)vertex). Having chosen *
c * vertex 1, the user may number the remaining vertices in *
c * either direction. However if the user wishes to use the *
c * subroutine SPA to determine the area of the polygon S (Bevis *
c * & Cambareri, 1987, Math. Geol., v.19, p. 335-346) then he or *
c * she must follow the convention whereby in moving around the *
c * polygon border in the direction of increasing vertex number *
c * clockwise bends occur at salient vertices. A vertex is *
c * salient if the interior angle is less than 180 degrees. *
c * (In the case of a convex polygon this convention implies *
c * that vertices are numbered in clockwise sequence). *
c ****************************************************************
implicit none
integer mxnv,nv
c ----------------------------------------------------------------
c Edit next statement to increase maximum number of vertices that
c may be used to define the spherical polygon S
c The value of parameter mxnv in subroutine LctPtRelBndry must match
c that of parameter mxnv in this subroutine, as assigned above.
c ----------------------------------------------------------------
parameter (mxnv=500)
real vlat(nv),vlon(nv),xlat,xlon,dellon
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
integer i,ibndry,nv_c,ip
data ibndry/0/
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
if (nv.gt.mxnv) then
print *,'nv exceeds maximum allowed value'
print *,'adjust parameter mxnv in subroutine DefSPolyBndry'
stop
endif
ibndry=1 ! boundary defined at least once (flag)
nv_c=nv ! copy for named common
xlat_c=xlat ! . . . .
xlon_c=xlon !
do i=1,nv
vlat_c(i)=vlat(i) ! "
vlon_c(i)=vlon(i) !
call TrnsfmLon(xlat,xlon,vlat(i),vlon(i),tlonv(i))
if (i.gt.1) then
ip=i-1
else
ip=nv
endif
if ((vlat(i).eq.vlat(ip)).and.(vlon(i).eq.vlon(ip))) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' and ',ip,' are not distinct'
print*,'lat ',i,ip,vlat(i),vlat(ip)
print*,'lon ',i,ip,vlon(i),vlon(ip)
stop
endif
if (tlonv(i).eq.tlonv(ip)) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' & ',ip,' on same gt. circle as X'
stop
endif
if (vlat(i).eq.(-vlat(ip))) then
dellon=vlon(i)-vlon(ip)
if (dellon.gt.+180.) dellon=dellon-360.
if (dellon.lt.-180.) dellon=dellon-360.
if ((dellon.eq.+180.0).or.(dellon.eq.-180.0)) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' and ',ip,' are antipodal'
stop
endif
endif
enddo
return
end
c ****************************************************************
Subroutine LctPtRelBndry(plat,plon,location)
c ****************************************************************
c ****************************************************************
c * This routine is used to see if some point P is located *
c * inside, outside or on the boundary of the spherical polygon *
c * S previously defined by a call to subroutine DefSPolyBndry. *
c * There is a single restriction on point P: it must not be *
c * antipodal to the point X defined in the call to DefSPolyBndry*
c * (ie.P and X cannot be seperated by exactly 180 degrees). *
c * ARGUMENTS: *
c * plat,plon (sent)... the latitude and longitude of point P *
c * location (returned)... specifies the location of P: *
c * location=0 implies P is outside of S *
c * location=1 implies P is inside of S *
c * location=2 implies P on boundary of S *
c * location=3 implies user error (P is *
c * antipodal to X) *
c * UNFfS AND SIGN CONVENTION: *
c * Latitudes and longitudes are specified in degrees. *
c * Latitudes are positive to the north and negative to the *
c * south. *
c * Longitudes are positive to the east and negative to the *
c * west. *
c ****************************************************************
implicit none
integer mxnv
c ----------------------------------------------------------------
c The statement below must match that in subroutine DefSPolyBndry
c ----------------------------------------------------------------
parameter (mxnv=500)
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
real plat,plon,vAlat,vAlon,vBlat,vBlon,tlonA,tlonB,tlonP
real tlon_X,tlon_P,tlon_B,dellon
integer i,ibndry,nv_c,location,icross,ibrngAB,ibrngAP,ibrngPB
integer ibrng_BX,ibrng_BP,istrike
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
if (ibndry.eq.0) then ! user has never defined the bndry
print*,'Subroutine LctPtRelBndry detects user error:'
print*,'Subroutine DefSPolyBndry must be called before'
print*,'subroutine LctPtRelBndry can be called'
stop
endif
if (plat.eq.(-xlat_c)) then
dellon=plon-xlon_c
if (dellon.lt.(-180.)) dellon=dellon+360.
if (dellon.gt.+180.) dellon=dellon-360.
if ((dellon.eq.+180.0).or.(dellon.eq.-180.)) then
print*,'Warning: LctPtRelBndry detects case P antipodal
> to X'
print*,'location of P relative to S is undetermined'
location=3
return
endif
endif
location=0 ! default ( P is outside S)
icross=0 ! initialize counter
if ((plat.eq.xlat_c).and.(plon.eq.xlon_c)) then
location=1
return
endif
call TrnsfmLon (xlat_c,xlon_c,plat,plon,tlonP)
do i=1,nv_c ! start of loop over sides of S
vAlat=vlat_c(i)
vAlon=vlon_c(i)
tlonA=tlonv(i)
if (i.lt.nv_c) then
vBlat=vlat_c(i+1)
vBlon=vlon_c(i+1)
tlonB=tlonv(i+1)
else
vBlat=vlat_c(1)
vBlon=vlon_c(1)
tlonB=tlonv(1)
endif
istrike=0
if (tlonP.eq.tlonA) then
istrike=1
else
call EastOrWest(tlonA,tlonB,ibrngAB)
call EastOrWest(tlonA,tlonP,ibrngAP)
call EastOrWest(tlonP,tlonB,ibrngPB)
if((ibrngAP.eq.ibrngAB).and.(ibrngPB.eq.ibrngAB)) istrike=1
endif
if (istrike.eq.1) then
if ((plat.eq.vAlat).and.(plon.eq.vAlon)) then
location=2 ! P lies on a vertex of S
return
endif
call TrnsfmLon(vAlat,vAlon,xlat_c,xlon_c,tlon_X)
call TrnsfmLon(vAlat,vAlon,vBlat,vBlon,tlon_B)
call TrnsfmLon(vAlat,vAlon,plat,plon,tlon_P)
if (tlon_P.eq.tlon_B) then
location=2 ! P lies on side of S
return
else
call EastOrWest(tlon_B,tlon_X,ibrng_BX)
call EastOrWest(tlon_B,tlon_P,ibrng_BP)
if(ibrng_BX.eq.(-ibrng_BP)) icross=icross+1
endif
endif
enddo ! end of loop over the sides of S
c if the arc XP crosses the boundary S an even number of times then P
c is in S
if (mod(icross,2).eq.0) location=1
return
end
c ****************************************************************
subroutine TrnsfmLon(plat,plon,qlat,qlon,tranlon)
c ****************************************************************
c * This subroutine is required by subroutines DefSPolyBndry & *
c * LctPtRelBndry. It finds the 'longitude' of point Q in a *
c * geographic coordinate system for which point P acts as a *
c * 'north pole'. SENT: plat,plon,qlat,qlon, in degrees. *
c * RETURNED: tranlon, in degrees. *
c ****************************************************************
implicit none
real pi,dtr,plat,plon,qlat,qlon,tranlon,t,b
parameter (pi=3.141592654,dtr=pi/180.0)
if (plat.eq.90.) then
tranlon=qlon
else
t=sin((qlon-plon)*dtr)*cos(qlat*dtr)
b=sin(dtr*qlat)*cos(plat*dtr)-cos(qlat*dtr)*sin(plat*dtr)
> *cos((qlon-plon)*dtr)
tranlon=atan2(t,b)/dtr
endif
return
end
c ****************************************************************
subroutine EastOrWest(clon,dlon,ibrng)
c ****************************************************************
c * This subroutine is required by subroutine LctPtRelBndry. *
c * This routine determines if in travelling the shortest path *
c * from point C (at longitude clon) to point D (at longitude *
c * dlon) one is heading east, west or neither. *
c * SENT: clon,dlon; in degrees. RETURNED: ibrng *
c * (1=east,-1=west, 0=neither). *
c ****************************************************************
implicit none
real clon,dlon,del
integer ibrng
del=dlon-clon
if (del.gt.180.) del=del-360.
if (del.lt.-180.) del=del+360.
if ((del.gt.0.0).and.(del.ne.180.)) then
ibrng=-1 ! (D is west of C)
elseif ((del.lt.0.0).and.(del.ne.-180.)) then
ibrng=+1 ! (D is east of C)
else
ibrng=0 ! (D north or south of C)
endif
return
end

/tags/1.0/create_startf/create_startf.m
0,0 → 1,30
% -------------------------------------------------------------------------
% Plot horizontal starting positions
% -------------------------------------------------------------------------
% Load starting points
[ start.lon start.lat start.p ] = textread('TEST','%f %f %f',-1);
% Open a new figure and set the geographical projection and region
figure(1);
clf;
load coast
h=axesm('MapProjection','stereo','origin',[ 90 70 ]);
gridm;
h=plotm(lat,long,'Color','k','LineWidth',1.5)
%axis([-1.5 1.5 -2 0]);
% Plot starting points
for i=1:length(start.lon)
linem(start.lat(i),start.lon(i),'marker','o', ...
'markersize',4,'color','w','MarkerEdgeColor',[.4 .4 .4], ...
'MarkerFaceColor','b');
end
% Save figure
figname = [ 'startf.eps' ];
set(gcf, 'PaperPosition', [2 1 15 10]);
print('-depsc2','-r0',figname);

/tags/1.0/create_startf/create_startf.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = create_startf.o ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/ioinp.a ${LAGRANTO}/lib/inter.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
create_startf: $(OBJS)
${F77} -o create_startf $(OBJS) ${INCS} $(LIBS)

/tags/1.0/create_startf/create_startf.perl
0,0 → 1,208
#!/usr/bin/perl
# --------------------------------------------------------
# Separate different commands out (delimiter @)
# --------------------------------------------------------
# Get input command and remove all spaces
$cmd = $ARGV[0];
$_ = $cmd;s/\s+//g;$cmd=$_;
$len = length $cmd;
# Split the command string according to logical operators
$nline = 0;
while ( $len > 0 )
{
# Get the length of the (remaining) command string
$len = length $cmd;
# Get the position of the next command separator
$at = index($cmd,'@');
if ( $at == -1 )
{ $next = $len+1; }
elsif ( $at >= 0 )
{ $next = $at; }
# A logical operator is not allowed to be at position 0
if ( $next == 0)
{
die('Invalid expression... Check @ separator position ');
}
# Extract the next substring
$sub = substr($cmd,0,$next);
$cmd = substr($cmd,$next+1,$len-$next-1);
$len = length $cmd;
# Save the command in a new line
@field[$nline] = $sub;
$nline = $nline + 1;
}
# Number of lines ist too large by 1
$nline = $nline - 1;
# Set some defaults
if ( $nline == 2 )
{
$nline = 3;
@field[3] = 'nil';
}
if ( $nline == 1 )
{
$nline = 3;
@field[2] = 'hPa';
@field[3] = 'nil';
}
if ( $nline == 0 )
{
$nline = 3;
@field[1] = 'nil()';
@field[2] = 'hPa';
@field[3] = 'nil';
}
# --------------------------------------------------------
# Handle each command line separately
# --------------------------------------------------------
# ----- Horizontal grid ----------------------------------
# Now looking at the horizontal grid specifier
$entry = @field[0];
# Extract the command and the parameter list
$left = index($entry,'(');
$right = index($entry,')');
if ( ($left != -1) && ($right != -1) )
{
$cmd = substr($entry,0,$left);
$list = substr($entry,$left+1,$right-$left-1);
$len = length $list;
}
else
{
die('Invalid expression... Check horizontal [] separator position ');
}
# Now building the parametr list
$len = length $list;
$npar = 0;
while ( $len > 0 )
{
$next = index($list,',');
if ( $next != -1 )
{
@param[$npar] = substr($list,0,$next);
$list = substr($list,$next+1,$len-$next-1);
$len = length $list;
$npar = $npar + 1;
}
else
{
@param[$npar] = substr($list,0,$len);
$len = 0;
$npar = $npar + 1;
}
}
# Check for syntax (needed number of parameters)
if ( ($cmd eq "file") && ($npar != 1) )
{ die('Invalid horizontal mode[file]... Check number of parameters '); }
if ( ($cmd eq "line") && ($npar != 5) )
{ die('Invalid horizontal mode[line]... Check number of parameters '); }
if ( ($cmd eq "box.eqd") && ($npar != 5) )
{ die('Invalid horizontal mode[box.eqd]... Check number of parameters '); }
if ( ($cmd eq "box.grid") && ($npar != 4) )
{ die('Invalid horizontal mode[box.grid]... Check number of parameters '); }
if ( ($cmd eq "point") && ($npar != 2) )
{ die('Invalid horizontal mode[point]... Check number of parameters '); }
if ( ($cmd eq "shift") && ($npar != 4) )
{ die('Invalid horizontal mode[shift]... Check number of parameters '); }
if ( ($cmd eq "poly.eqd") && ($npar != 2) )
{ die('Invalid horizontal mode[poly.eqd]... Check number of parameters '); }
if ( ($cmd eq "poly.grid") && ($npar != 1) )
{ die('Invalid horizontal mode[poly.grid]... Check number of parameters ');}
# Write parameters
print "\"$cmd\"\n";
print "@param\n";
# ----- Vertical grid ----------------------------------------
# Now looking at the vertical grid specifier
$entry = @field[1];
# Extract the command and the parameter list
$left = index($entry,'(');
$right = index($entry,')');
if ( ($left != -1) && ($right != -1) )
{
$cmd = substr($entry,0,$left);
$list = substr($entry,$left+1,$right-$left-1);
$len = length $list;
}
else
{
die('Invalid expression... Check vertical [] separator position ');
}
# Now building the parametr list
$len = length $list;
$npar = 0;
while ( $len > 0 )
{
$next = index($list,',');
if ( $next != -1 )
{
@param[$npar] = substr($list,0,$next);
$list = substr($list,$next+1,$len-$next-1);
$len = length $list;
$npar = $npar + 1;
}
else
{
@param[$npar] = substr($list,0,$len);
$len = 0;
$npar = $npar + 1;
}
}
# Check for syntax (needed number of parameters)
if ( ($cmd eq "file") && ($npar != 1) )
{ die('Invalid vertical mode[file]... Check number of parameters '); }
if ( ($cmd eq "level") && ($npar != 1) )
{ die('Invalid vertical mode[level]... Check number of parameters '); }
if ( ($cmd eq "list") && ($npar == 0) )
{ die('Invalid vertical mode[list]... Check number of parameters '); }
if ( ($cmd eq "profile") && ($npar != 3) )
{ die('Invalid vertical mode[profile]... Check number of parameters '); }
if ( ($cmd eq "grid") && ($npar != 2) )
{ die('Invalid vertical mode[grid]... Check number of parameters '); }
# Write parameters
print "\"$cmd\"\n";
if ( $cmd eq "list") { print "$npar\n"; }
if ( $npar > 0 )
{ print "@param\n"; }
# ----- Vertical coordinate system ----------------------------------
# Now looking at the vertical grid specifier
$cmd = @field[2];
# Check for allowed coordinate axes
if ( ($cmd ne "hPa") && ($cmd ne "hPa,agl") && ($cmd ne "K") && ($cmd ne "PVU") && ($cmd ne "INDEX") )
{ die('Invalid vertical axis [allowed: hPa / hPa,agl / K / PVU / INDEX] '); }
# Write command
print "\"$cmd\"\n";
# ----- Selection criteria --------------------------------------------
# Now looking at the selection specifier
$cmd = @field[3];
# Write command
print "$cmd\n";
Property changes:
Added: svn:executable

/tags/1.0/create_startf/create_startf.sh
0,0 → 1,347
#!/bin/csh
# -----------------------------------------------------------------------------------------------------------------
# Usage and parameter handling
# -----------------------------------------------------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0 ) then
echo
${LAGRANTO}/bin/lagrantohelp create_startf short
echo
exit 1
endif
# -----------------------------------------------------------------------------------------------------------------
# Handle input parameters
# -----------------------------------------------------------------------------------------------------------------
# Prefix of primary and secondary file; and set the filenames
set charp='P'
set chars='S'
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR CREATE_STARTF *** '
echo
# Extract arguments and split reference date
set refdate = $1
set ofile = $2
set specifier = `echo $3`
shift
shift
shift
# Check whether specifier is a file or whether it is explicitly written
set flag_criterion = 'file'
set test = `echo ${specifier} | grep '@' | wc -c`
if ( "${test}" != "0" ) then
set flag_criterion = 'criterion'
endif
# Get the criterion from the file
if ( "${flag_criterion}" == "file" ) then
if ( -f ${specifier} ) then
set filename = ${specifier}
set specifier = `cat ${specifier}`
else
echo " ERROR: cannot read criterion from file ${specifier}... Stop"
exit 1
endif
endif
echo "---- INPUT PARAMETERS ----------------------------------"
echo
echo "Reference date : ${refdate}"
if ( "${flag_criterion}" == "criterion" ) then
echo "Specifier : ${specifier}"
else
echo "Specifier : ${specifier} [from file ${filename}]"
endif
echo "Output file : ${ofile}"
echo
# Handle optional arguments
set tvfile = 'tracevars'
set changet = 'false'
set noclean = 'false'
set regionf = 'regionf'
set timecheck = 'no'
while ( $#argv > 0 )
switch ( $argv[1] )
case -t
set tvfile = $argv[2]
echo "tvfile -> ${tvfile} (user defined)"
shift;
breaksw
case -changet
set changet = 'true'
echo "changet -> true (user defined)"
breaksw
case -noclean
set noclean = 'true'
echo "noclean -> true (user defined)"
breaksw
case -timecheck
set timecheck = 'yes'
echo "timecheck -> yes (user defined)"
breaksw
case -regionf
set regionf = $argv[2]
echo "regionf -> ${regionf} (user defined)"
shift;
breaksw
endsw
shift;
end
# No change of times necessary if no check requested
if ( "${timecheck}" == "no" ) then
set changet = 'false'
endif
# Split the reference date
set yyyy=`echo ${refdate} | cut -c 1-4`
set mm=`echo ${refdate} | cut -c 5-6`
set dd=`echo ${refdate} | cut -c 7-8`
set hh=`echo ${refdate} | cut -c 10-11`
set min=`echo ${refdate}00 | cut -c 12-13`
# Set base directories (run+prog)
set tradir=${PWD}
# Set program paths and filenames
set parfile=${tradir}/create_startf.param
set crifile=${tradir}/create_startf.criterion
# Decide whether a tracing and selection is necessary
# If so, some intermediate file are writen (in Fortran binary)
set flag = `${LAGRANTO}/startf/create_startf.perl "${specifier}" | tail -1`
if ( "${flag}" != "nil" ) then
set format1 = ".3"
set format2 = ".3"
else
set format1 = ""
set format2 = ""
endif
# Write status information
echo
echo '---- DIRECTORIES AND PROGRAMS ---------------------------'
echo
echo "PROGRAM CREATE_STARTF : ${LAGRANTO}/startf/create_startf"
echo "PARAMETER file : ${parfile}"
echo "CRITERION file : ${crifile}"
echo "RUN directory : ${tradir}"
echo
# -----------------------------------------------------------------------------------------------------------------
# Set the primary and scecondary data files (necessary for interpolation if intermediate reference date)
# -----------------------------------------------------------------------------------------------------------------
# Find a first data file (if possible corresponding to reference date)
set file=${charp}${yyyy}${mm}${dd}_${hh}
if ( ( -f ${file} ) && ( ${min} == 0 ) ) then
set timeshift=0
set date0=${yyyy}${mm}${dd}_${hh}
set date1=${yyyy}${mm}${dd}_${hh}
set pfile0=${file1}
set pfile1=${file}
goto label3
else
set file=`ls ${charp}[0-9_]*[0-9] | head -1 | sed -e 's/@//'`
endif
# Determine time increment (in hours) between data files
set date1=`echo $file | cut -c 2-12`
set n=`ls ${charp}[0-9_]*[0-9] | grep -n $date1 | awk -F: '{print $1}'`
@ n ++
set date2=`ls ${charp}[0-9_]*[0-9] | head -$n | tail -1 | cut -c 2-12`
set timeinc=`${LAGRANTO}/goodies/gettidiff $date2 $date1`
endif
if ( $timeinc == 0 ) then
echo " ERROR: cannot set the time increment between input files ***"
exit 1
endif
# Search the first file to use
set timeshift=
foreach i ( ${charp}????????_?? )
set date0 = `echo $i | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${yyyy}${mm}${dd}_${hh} ${date0}`
if ( ( $td1 >= 0 ) && ( $td1 < $timeinc ) ) then
set timeshift=$td1
set pfile0=${charp}${date0}
goto label2
endif
end
# Check if no P files are available for the specified time period
if ( $timeshift == "" ) then
echo " ERROR: no data files available for the specified reference date"
exit 1
endif
# Everything is fine so far: proceed
label2:
# Set the next date and check its availability
if ( ( ${timeshift} != 0 ) || ( ${min} > 0 ) ) then
set date1=`${LAGRANTO}/goodies/newtime $date0 $timeinc`
if ( ! -f ${charp}${date1} ) then
echo " ERROR: file with primary data is missing for $date1"
exit 1
else
set pfile1=${charp}${date1}
endif
else
set date1=${date0}
set pfile1=${pfile0}
endif
# Set the final timeshift
if ( ${min} != 00 ) then
set timeshift=${timeshift}.${min}
endif
# Everything is fine!
label3:
# Set secondary files and check their availability
set sfile0=${chars}${date0}
set sfile1=${chars}${date1}
# Write status information
echo '---- DATA FILES -----------------------------------------'
echo
echo "Primary files : ${pfile0}"
echo " : ${pfile1}"
echo "Secondary files : ${sfile0}"
echo " : ${sfile1}"
echo "Timeshift to first data file (hh.mm) : ${timeshift}"
echo "Time increment of data files : ${timeinc}"
echo
# --------------------------------------------------------------------------------------------------------------
# Create the start positions (without selection)
# -----------------------------------------------------------------------------------------------------------------
# Set times relative to the reference date
if ( "${changet}" == "true" ) then
echo '---- CHANGE TIMES ON DATA FILES ------------------------'
echo
${LAGRANTO}/goodies/changet.sh ${refdate} ${pfile0}
${LAGRANTO}/goodies/changet.sh ${refdate} ${pfile1}
if ( -f ${sfile0} ) then
${LAGRANTO}/goodies/changet.sh ${refdate} ${sfile0}
endif
if ( -f ${sfile1} ) then
${LAGRANTO}/goodies/changet.sh ${refdate} ${sfile1}
endif
endif
# Write parameters to parameter file and create the starting positions
\rm -f ${parfile}
echo \"${pfile0}\" \"${pfile1}\" >! ${parfile}
echo \"${sfile0}\" \"${sfile1}\" >> ${parfile}
echo \"${ofile}${format1}\" >> ${parfile}
echo \"${regionf}\" >> ${parfile}
echo ${yyyy} >> ${parfile}
echo ${mm} >> ${parfile}
echo ${dd} >> ${parfile}
echo ${hh} >> ${parfile}
echo ${min} >> ${parfile}
echo 00 >> ${parfile}
echo ${timeshift} >> ${parfile}
echo ${timeinc} >> ${parfile}
# Analyse the specifier and append to parameter file
${LAGRANTO}/startf/create_startf.perl "${specifier}" >> ${parfile}
if ( "${status}" != "0" ) then
echo "ERROR: Preprocessor <create_startf> failed"
exit 1
endif
# Write selection criterion to file
\rm -f ${crifile}
tail -1 ${parfile} >! ${crifile}
# Write flag for no time check
echo \"${timecheck}\" >> ${parfile}
# Write title
echo
echo ' *** END OF PREPROCESSOR CREATE_STARTF ***'
echo '========================================================='
echo
# Create the startf
cd ${tradir}
${LAGRANTO}/startf/create_startf
if ( "${status}" != "0" ) then
echo "ERROR: Program <create_startf> failed"
exit 1
endif
# --------------------------------------------------------------------------------------------------------------
# Apply selection (first tracing then selection)
# --------------------------------------------------------------------------------------------------------------
# Stop if no tracing and selection is necessary
if ( "${flag}" == "nil" ) goto finish
# Tracing of extra variables
if ( -f ${ofile}${format2} ) then
\rm -f ${ofile}${format2}
endif
if ( "${timecheck}" == "no" ) then
${LAGRANTO}/trace/trace.sh ${ofile}${format1} ${ofile}${format2} -v ${tvfile} -notimecheck
else
${LAGRANTO}/trace/trace.sh ${ofile}${format1} ${ofile}${format2} -v ${tvfile}
endif
\rm -f ${ofile}${format1}
# Selection
if ( -f ${ofile} ) then
\rm -f ${ofile}
endif
${LAGRANTO}/select/select.sh ${ofile}${format2} ${ofile} `cat ${crifile}`
\rm -f ${ofile}${format2}
# --------------------------------------------------------------------------------------------------------------
# Final tasks (make clean)
# --------------------------------------------------------------------------------------------------------------
finish:
echo $noclean
if ( "${noclean}" == "false" ) then
\rm -f ${crifile}
\rm -f ${parfile}
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/data
0,0 → 1,0
link /data/lagranto.20cr/
Property changes:
Added: svn:special
+*
\ No newline at end of property

/tags/1.0/density/density.f
0,0 → 1,1754
PROGRAM density
use netcdf
implicit none
c ---------------------------------------------------------------------
c Declaration of variables
c ---------------------------------------------------------------------
c Parameter and working arrays
real radius
character*80 runit
integer nx,ny
integer nlonlat
real dlonlat
real xmin,ymin,dx,dy
real clon,clat
integer ntime,nfield,ntra
character*80 inpfile
character*80 outfile
character*80 mode
real param
integer opts,npts
integer step
character*80 gridtype
character*80 field
integer crefile,crevar
real,allocatable, dimension (:,:) :: cnt,res,fld,area
real,allocatable, dimension (:) :: traj
real,allocatable, dimension (:) :: olon,olat,otim,ofld
real,allocatable, dimension (:) :: nlon,nlat,ntim,nfld
c Output format
character*80 outformat
c Physical and mathematical constants
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay=111.)
real eps
parameter (eps=0.001)
c Input trajectories (see iotra.f)
integer inpmode
real,allocatable, dimension (:,:,:) :: trainp
integer reftime(6)
character*80 varsinp(100)
integer,allocatable, dimension (:) :: sel_flag
character*80 sel_file
character*80 sel_format
c Auxiliary variables
character*80 cdfname,varname
integer i,j,k
integer stat
integer,allocatable, dimension (:,:) :: connect0
integer connectval0
integer,allocatable, dimension (:,:) :: connect1
integer connectval1
integer,allocatable, dimension (:,:) :: connect2
integer connectval2
real slat
integer ipre
real addvalue
real xmax,ymax
real ,allocatable, dimension (:) :: odist,ndist
real dt
integer fid
integer dynamic_grid
real ycen,xcen
integer indx,indy
character*80 unit
real pollon,pollat
real rlon0,rlat0,rlon,rlat
real lon,lat
real crot
integer count
character*80 longname, varunit
real time
integer ind
integer ifield
real hhmm,frac
integer ierr,ncID
c External functions
real lmstolm,lmtolms
real phstoph,phtophs
external lmstolm,lmtolms,phstoph,phtophs
real sdis
external sdis
c ---------------------------------------------------------------------
c Preparations
c ---------------------------------------------------------------------
c Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM DENSITY ***'
print*
c Read input parameters
open(10,file='density.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) field
read(10,*) ntime,nfield,ntra
read(10,*) gridtype
if ( gridtype.eq.'latlon' ) then
read(10,*) nx,ny,xmin,ymin,dx,dy
elseif ( gridtype.eq.'rotated') then
read(10,*) clon,clat,nlonlat,dlonlat
else
print*,' ERROR: unsupported grid type ',trim(gridtype)
stop
endif
read(10,*) radius,runit
read(10,*) mode
read(10,*) param
read(10,*) step
read(10,*) sel_file
read(10,*) sel_format
read(10,*) crefile
read(10,*) crevar
close(10)
c Get the grid parameters if <crefile=0>
if ( crefile.eq.0 ) then
ierr = nf90_open (trim(outfile), NF90_NOWRITE , ncID)
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'grid' ,gridtype )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'clon' ,clon )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'clat' ,clat )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'nlonlat',nlonlat )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'dlonlat',dlonlat )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'nx' ,nx )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'ny' ,ny )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'dx' ,dx )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'dy' ,dy )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'xmin' ,xmin )
ierr = nf90_get_att(ncID, NF90_GLOBAL, 'ymin' ,ymin )
ierr = nf90_close(ncID)
print*,'**** GRID PARAMETERS IMPORTED ',
> 'FROM NETCDF FILE!!!! ****'
print*
endif
c Check for consistency
if ( (step.ne.0).and.(mode.ne.'keep') ) then
print*," ERROR: interpolation is only possible for all",
> ' time steps... Stop'
stop
endif
c Set the number of times (just code aesthetics)
opts=ntime
c Set grid parameters for rotated grid
if ( gridtype.eq.'rotated' ) then
nx = nlonlat
ny = nlonlat
dx = dlonlat
dy = dlonlat
xmin = - real(nlonlat-1)/2. * dx
xmax = + real(nlonlat-1)/2. * dx
ymin = - real(nlonlat-1)/2. * dy
ymax = + real(nlonlat-1)/2. * dy
endif
c Set the flag for dynamic grid adjustment
if ( (nx.eq.0).or.(ny.eq.0) ) then
dynamic_grid = 1
else
dynamic_grid = 0
endif
c Print status information
print*,'---- INPUT PARAMETERS -----------------------------------'
print*
print*,'Input : ',trim(inpfile)
print*,'Output : ',trim(outfile)
print*,'Field : ',trim(field)
print*,'Trajectory : ',ntime,nfield,ntra
print*,'Grid type : ',trim(gridtype)
if ( dynamic_grid.eq.1 ) then
print*,'Grid : dynamic (see below)'
elseif ( gridtype.eq.'latlon' ) then
print*,'Grid nlon,nlat : ',nx,ny
print*,' lonmin,latmin : ',xmin,ymin
print*,' dlon,dlat : ',dx,dy
elseif ( gridtype.eq.'rotated' ) then
print*,'Grid clon,clat : ',clon,clat
print*,' nlonlat : ',nlonlat
print*,' dlonlat : ',dlonlat
endif
print*,'Filter radius : ',radius,' ',trim(runit)
print*,'Mode : ',trim(mode)
if ( ( mode.eq.'time' ).or.
> ( mode.eq.'space' ).or.
> (mode.eq.'grid' ) )
>then
print*,'Parameter : ',param
endif
if ( step.eq.0 ) then
print*,'Time step : all'
elseif (step.gt.0) then
print*,'Time step : ',step
endif
print*,'Selection file : ',trim(sel_file)
print*,'Selection format : ',trim(sel_file)
print*,'Flag <crefile> : ',crefile
print*,'Flag <crevar> : ',crevar
c Check whether mode is valid
if ((mode.ne.'keep' ).and.
> (mode.ne.'time' ).and.
> (mode.ne.'space' ).and.
> (mode.ne.'grid' ))
>then
print*,' ERROR: Invalid mode ',trim(mode)
stop
endif
c Allocate memory for old and new (reparameterised) trajectory
allocate(olon(ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array olon ***'
allocate(olat(ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array olat ***'
allocate(otim(ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array otim ***'
allocate(nlon(1000*ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array nlon ***'
allocate(nlat(1000*ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array nlat ***'
allocate(ntim(1000*ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array ntim ***'
allocate(odist(ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array odist ***'
allocate(ndist(1000*ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array ndist ***'
allocate(ofld(ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array ofld ***'
allocate(nfld(1000*ntime),stat=stat)
if (stat.ne.0) print*,'*** error allocating array nfld ***'
c Allocate memory for complete trajectory set
allocate(trainp(ntra,ntime,nfield),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp ***'
allocate(sel_flag(ntra),stat=stat)
if (stat.ne.0) print*,'*** error allocating array sel_flag ***'
c Allocate memory for auxiliary fields
allocate(traj(nfield),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traj ***'
c Set the format of the input file
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
c Read the input trajectory file
call ropen_tra(fid,inpfile,ntra,ntime,nfield,
> reftime,varsinp,inpmode)
call read_tra (fid,trainp,ntra,ntime,nfield,inpmode)
call close_tra(fid,inpmode)
c Check that first four columns correspond to time,lon,lat,p
if ( (varsinp(1).ne.'time' ).or.
> (varsinp(2).ne.'xpos' ).and.(varsinp(2).ne.'lon' ).or.
> (varsinp(3).ne.'ypos' ).and.(varsinp(3).ne.'lat' ).or.
> (varsinp(4).ne.'ppos' ).and.(varsinp(4).ne.'p' ) )
>then
print*,' ERROR: problem with input trajectories ...'
stop
endif
varsinp(1) = 'TIME'
varsinp(2) = 'lon'
varsinp(3) = 'lat'
varsinp(4) = 'p'
c Get the index of the field (if needed)
if ( field.ne.'nil' ) then
ifield = 0
do i=1,nfield
if ( varsinp(i).eq.field ) ifield = i
enddo
if ( ifield.eq.0 ) then
print*,' ERROR: field ',trim(field),' not found... Stop'
stop
endif
endif
c Write some status information of the input trajectories
print*
print*,'---- INPUT TRAJECTORIES ---------------------------------'
print*
print*,' Reference time (year) : ',reftime(1)
print*,' (month) : ',reftime(2)
print*,' (day) : ',reftime(3)
print*,' (hour) : ',reftime(4)
print*,' (min) : ',reftime(5)
print*,' Time range (min) : ',reftime(6)
do i=1,nfield
if ( i.ne.ifield ) then
print*,' Var :',i,trim(varsinp(i))
else
print*,' Var :',i,trim(varsinp(i)),
> ' [ gridding ]'
endif
enddo
print*,' List of selected times'
do i=1,ntime
if ( (step.eq.0).or.(step.eq.i) ) then
print*,' ',i,' -> ',trainp(1,i,1)
endif
enddo
print*
c Select flag: all trajectories are selected
if ( sel_file.eq.'nil' ) then
do i=1,ntra
sel_flag(i) = 1
enddo
c Select flag: index file
elseif ( sel_format.eq.'index' ) then
do i=1,ntra
sel_flag(i) = 0
enddo
open(10,file=sel_file)
142 read(10,*,end=141) ind
sel_flag(ind) = 1
goto 142
141 continue
close(10)
c Select flag: boolean file
elseif ( sel_format.eq.'boolean' ) then
open(10,file=sel_file)
do i=1,ntra
read(10,*) ind
if ( ind.eq.1 ) sel_flag(i) = ind
enddo
close(10)
endif
c Write status information
if ( sel_file.eq.'nil' ) then
print*,' Selected trajectories : all ',ntra
else
count = 0
do i=1,ntra
if ( sel_flag(i).eq.1 ) count = count + 1
enddo
print*,' #selected trajectories : ',count,
> ' [ ',real(count)/real(ntra) * 100.,' % ] '
endif
print*
c ---------------------------------------------------------------------
c Coordinate transformations and grid adjustment
c ---------------------------------------------------------------------
c Transform from lat/lon to rotated lat/lon, if requested
if ( gridtype.eq.'rotated') then
crot = 0.
pollon=clon-180.
if (pollon.lt.-180.) pollon=pollon+360.
pollat=90.-clat
do i=1,ntra
do j=1,ntime
if ( sel_flag(i).eq.1 ) then
c Get lat/lon coordinates for trajectory point
lon = trainp(i,j,2)
lat = trainp(i,j,3)
c First Rotation
pollon=clon-180.
if (pollon.lt.-180.) pollon=pollon+360.
pollat=90.-clat
rlon0=lmtolms(lat,lon,pollat,pollon)
rlat0=phtophs(lat,lon,pollat,pollon)
c Second rotation
pollon=-180.
pollat=90.+crot
rlon=90.+lmtolms(rlat0,rlon0-90.,pollat,pollon)
rlat=phtophs(rlat0,rlon0-90.,pollat,pollon)
c Get rotated latitude and longitude
100 if (rlon.lt.xmin) then
rlon=rlon+360.
goto 100
endif
102 if (rlon.gt.(xmin+real(nx-1)*dx)) then
rlon=rlon-360.
goto 102
endif
c Set the new trajectory coordinates
trainp(i,j,2) = rlon
trainp(i,j,3) = rlat
endif
enddo
enddo
endif
c Dynamic grid adjustment
if ( dynamic_grid.eq.1 ) then
c Get the grid parameters
xmin = 180.
ymin = 90.
xmax = -180.
ymax = -90.
do i=1,ntra
if ( sel_flag(i).eq.1 ) then
if ( step.eq.0 ) then
do j=1,ntime
if ( trainp(i,j,2).lt.xmin) xmin = trainp(i,j,2)
if ( trainp(i,j,2).gt.xmax) xmax = trainp(i,j,2)
if ( trainp(i,j,3).lt.ymin) ymin = trainp(i,j,3)
if ( trainp(i,j,3).gt.ymax) ymax = trainp(i,j,3)
enddo
else
if ( trainp(i,step,2).lt.xmin) xmin = trainp(i,step,2)
if ( trainp(i,step,2).gt.xmax) xmax = trainp(i,step,2)
if ( trainp(i,step,3).lt.ymin) ymin = trainp(i,step,3)
if ( trainp(i,step,3).gt.ymax) ymax = trainp(i,step,3)
endif
endif
enddo
c Get first guess for "optimal" grid
nx = 400
ny = 400
dx = (xmax - xmin)/real(nx-1)
dy = (ymax - ymin)/real(ny-1)
c Make the grid spacing equal in zonal and meridional direction
if ( dx.gt.dy ) then
dy = dx
ny = (ymax - ymin)/dy + 1
if (ny.lt.nx/2) ny = nx / 2
if ( real(ny)*dy .ge. 180. ) ny = 180./dy + 1
ycen = 0.5* (ymin+ymax)
ymin = ycen - 0.5 * real(ny/2) * dy
if (ymin.le.-90.) ymin = -90.
else
dx = dy
nx = (xmax - xmin)/dx + 1
if (nx.lt.ny/2) nx = ny / 2
if ( real(nx)*dx .ge. 360. ) nx = 360./dx + 1
xcen = 0.5* (xmin+xmax)
xmin = xcen - 0.5 * real(nx/2) * dx
if (xmin.le.-180.) xmin = -180.
endif
c Write information
print*
print*,'---- DYNAMIC GRID ADJUSTMENT',
> ' ----------------------------'
print*
print*,'Grid nlon,nlat : ',nx,ny
print*,' lonmin,latmin : ',xmin,ymin
print*,' dlon,dlat : ',dx,dy
print*
c Write grid information for rotated grid (if not already done
elseif ( gridtype.eq.'rotated') then
print*
print*,'---- GRID PARAMETERS -------',
> ' ----------------------------'
print*
print*,'Grid nlon,nlat : ',nx,ny
print*,' lonmin,latmin : ',xmin,ymin
print*,' dlon,dlat : ',dx,dy
print*
endif
c Set the grid boundaries
xmax=xmin+real(nx-1)*dx
ymax=ymin+real(ny-1)*dy
c Allocate memory for output array and auxiliary gridding array
allocate(cnt(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array cnt ***'
allocate(res(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array res ***'
allocate(fld(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array fld ***'
allocate(area(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array area ***'
allocate(connect0(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array connect0 ***'
allocate(connect1(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array connect1 ***'
allocate(connect2(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array connect2 ***'
c Init the output array
do i=1,nx
do j=1,ny
connect0(i,j) = 0
connect1(i,j) = 0
connect2(i,j) = 0
cnt(i,j) = 0.
res(i,j) = 0.
fld(i,j) = 0.
enddo
enddo
c ---------------------------------------------------------------------
c Gridding
c ---------------------------------------------------------------------
c Write some status information
print*,'---- GRIDDING -------------------------------------------'
print*
c Loop over all entries of sampling table
connectval0 = 0
connectval1 = 0
connectval2 = 0
count = 0
do i=1,ntra
if (mod(i,100).eq.0) print*,i,' of ',ntra
c Skip all trajectories which are not selected
if ( sel_flag(i).eq.0 ) goto 300
c ------- Read a complete trajectory ---------------------------
do j=1,ntime
otim(j) = trainp(i,j,1)
olon(j) = trainp(i,j,2)
olat(j) = trainp(i,j,3)
if ( field.ne.'nil' ) then
ofld(j) =trainp(i,j,ifield)
endif
enddo
c -------- Convert hh.m time into fractional time --------------
do j=1,ntime
hhmm = otim(j)
call hhmm2frac (hhmm,frac)
otim(j) = frac
enddo
c -------- Interpolation ---------------------------------------
c Keep the trajectory points as they are
if ( ( mode.eq.'keep').and.(step.eq.0) ) then
npts=opts
do j=1,opts
ntim(j)=otim(j)
nlon(j)=olon(j)
nlat(j)=olat(j)
if ( field.ne.'nil' ) then
nfld(j)=ofld(j)
endif
enddo
c Select a single time step
elseif ( ( mode.eq.'keep').and.(step.gt.0) ) then
npts = 1
ntim(1) = otim(step)
nlon(1) = olon(step)
nlat(1) = olat(step)
if ( field.ne.'nil' ) then
nfld(1) = ofld(step)
endif
c Perform a reparameterisation in time
else if ( (mode.eq.'time').and.(step.eq.0) ) then
c Get the new number of trajectory points
npts=nint(abs(otim(opts)-otim(1))/param)+1
c Handle date line problem
do j=2,opts
if ( (olon(j-1)-olon(j)).gt.180. ) then
olon(j) = olon(j) + 360.
else if ( (olon(j-1)-olon(j)).lt.-180. ) then
olon(j) = olon(j) - 360.
endif
enddo
c Cubic spline fitting
call curvefit(otim,olon,opts,ntim,nlon,npts)
call curvefit(otim,olat,opts,ntim,nlat,npts)
if ( field.ne.'nil' ) then
call curvefit(otim,ofld,opts,ntim,nfld,npts)
endif
c Reverse date line handling
do j=1,npts
if ( nlon(j).gt.xmax ) then
nlon(j) = nlon(j) -360.
else if ( nlon(j).lt.xmin ) then
nlon(j) = nlon(j) +360.
endif
enddo
c Perform a reparameterisation with equally spaced gridpoint
elseif ( (mode.eq.'space').and.(step.eq.0) ) then
c Calculate the distance and spacing
odist(1) = 0.
unit = 'km'
do j=2,ntime
odist(j)=odist(j-1) +
> sdis(olon(j-1),olat(j-1),olon(j),olat(j),unit)
enddo
c Determine the new number of trajectory points
npts=nint(odist(ntime)/param)+1
if (npts.eq.0) then
npts=1.
endif
c Handle date line problem
do j=2,opts
if ( (olon(j-1)-olon(j)).gt.180. ) then
olon(j) = olon(j) + 360.
else if ( (olon(j-1)-olon(j)).lt.-180. ) then
olon(j) = olon(j) - 360.
endif
enddo
c Cubic spline fitting
call curvefit(odist,olon,opts,ndist,nlon,npts)
call curvefit(odist,olat,opts,ndist,nlat,npts)
call curvefit(odist,otim,opts,ndist,ntim,npts)
if ( field.ne.'nil' ) then
call curvefit(odist,ofld,opts,ndist,nfld,npts)
endif
c Reverse date line handling
do j=1,npts
if ( nlon(j).gt.xmax ) then
nlon(j) = nlon(j) -360.
else if ( nlon(j).lt.xmin ) then
nlon(j) = nlon(j) +360.
endif
enddo
c Perform a reparameterisation with equally spaced gridpoint
elseif ( (mode.eq.'grid').and.(step.eq.0) ) then
c Calculate the distance and spacing
odist(1) = 0.
unit = 'deg'
do j=2,ntime
odist(j)=odist(j-1) +
> sdis(olon(j-1),olat(j-1),olon(j),olat(j),unit)
enddo
c Determine the new number of trajectory points
npts=nint(odist(ntime)/param)+1
if (npts.eq.0) then
npts=1.
endif
c Handle date line problem
do j=2,opts
if ( (olon(j-1)-olon(j)).gt.180. ) then
olon(j) = olon(j) + 360.
else if ( (olon(j-1)-olon(j)).lt.-180. ) then
olon(j) = olon(j) - 360.
endif
enddo
c Cubic spline fitting
call curvefit(odist,olon,opts,ndist,nlon,npts)
call curvefit(odist,olat,opts,ndist,nlat,npts)
call curvefit(odist,otim,opts,ndist,ntim,npts)
if ( field.ne.'nil' ) then
call curvefit(odist,ofld,opts,ndist,nfld,npts)
endif
c Reverse date line handling
do j=1,npts
if ( nlon(j).gt.xmax ) then
nlon(j) = nlon(j) -360.
else if ( nlon(j).lt.xmin ) then
nlon(j) = nlon(j) +360.
endif
enddo
endif
c -------- Do the gridding -------------------------------------
c Gridding of trajectory
do j=1,npts
c Check whether point is in data domain
if ( (nlon(j).gt.xmin).and.(nlon(j).lt.xmax).and.
> (nlat(j).gt.ymin).and.(nlat(j).lt.ymax))
> then
c Increase counter for gridded points
count = count + 1
c ----------------- Gridding: simple count -----------------
connectval0 = connectval0+1
addvalue = 1.
call gridding1
> (nlat(j),nlon(j),addvalue,
> radius,runit,connect0,connectval0,
> cnt,nx,ny,xmin,ymin,dx,dy)
c ----------------- Gridding: residence time ---------------
connectval1 = connectval1+1
if ( ntime.eq.1 ) then
addvalue = 0.
elseif ( j.eq.1 ) then
addvalue=abs(ntim(2)-ntim(1))
else
addvalue=abs(ntim(j)-ntim(j-1))
endif
call gridding1
> (nlat(j),nlon(j),addvalue,
> radius,runit,connect1,connectval1,
> res,nx,ny,xmin,ymin,dx,dy)
c --------------- Gridding: field -------------------------
if ( field.ne.'nil' ) then
connectval2 = connectval2+1
addvalue = nfld(j)
call gridding1
> (nlat(j),nlon(j),addvalue,
> radius,runit,connect2,connectval2,
> fld,nx,ny,xmin,ymin,dx,dy)
endif
endif
enddo
c Exit point for loop over all trajectories
300 continue
enddo
c Write status information
print*
print*,' # gridded points : ',count
c ---------------------------------------------------------------------
c Unit conversions and output to netCDF file
c ---------------------------------------------------------------------
c Write some status information
print*
print*,'---- WRITE OUTPUT ---------------------------------------'
print*
c Area (in km^2)
do i=1,nx
do j=1,ny
slat=ymin+real(j-1)*dy
if (abs(abs(slat)-90.).gt.eps) then
area(i,j) = dy*dx*cos(pi180*slat)*deltay**2
else
area(i,j) = 0.
endif
enddo
enddo
c Normalise gridded field
if ( field.ne.'nil' ) then
do i=1,nx
do j=1,ny
if ( cnt(i,j).gt.0. ) then
fld(i,j) = fld(i,j) / cnt(i,j)
endif
enddo
enddo
endif
c Set the time for the output netCDF files - if a composite is
c calculatd, then the time is set to
if ( step.eq.0 ) then
time = -999.
print*,' ... COMPOSITE OVER ALL TRAJECTORY TIMES (-999)'
print*
else
time = trainp(1,step,1)
endif
c Write output to CF netCDF
cdfname = outfile
varname = 'COUNT'
longname = 'trajectory counts'
varunit = 'counts per grid point'
call writecdf2D_cf (cdfname,varname,longname,varunit,gridtype,
> clon,clat,nlonlat,dlonlat,cnt,time,dx,dy,xmin,ymin,nx,
> ny,crefile,crefile,1)
write(*,'(a8,a10,a5,a10,a10,f7.2,a2)')
> ' ... ',trim(varname),' -> ',trim(cdfname),
> ' [ time = ',time,' ]'
varname = 'RESIDENCE'
longname = 'residence time'
varunit = 'hours per grid point'
call writecdf2D_cf (cdfname,varname,longname,varunit,gridtype,
> clon,clat,nlonlat,dlonlat,res,time,dx,dy,xmin,ymin,nx,
> ny,0,crefile,1)
write(*,'(a8,a10,a5,a10,a10,f7.2,a2)')
> ' ... ',trim(varname),' -> ',trim(cdfname),
> ' [ time = ',time,' ]'
varname = 'AREA'
longname = 'area corresponding to grid points'
varunit = 'square kilometers'
call writecdf2D_cf (cdfname,varname,longname,varunit,gridtype,
> clon,clat,nlonlat,dlonlat,area,time,dx,dy,xmin,ymin,nx,
> ny,0,crefile,1)
write(*,'(a8,a10,a5,a10,a10,f7.2,a2)')
> ' ... ',trim(varname),' -> ',trim(cdfname),
> ' [ time = ',time,' ]'
if ( field.ne.'nil' ) then
varname = field
longname = field
varunit = 'as on trajectory file'
call writecdf2D_cf (cdfname,varname,longname,varunit,gridtype,
> clon,clat,nlonlat,dlonlat,fld,time,dx,dy,xmin,ymin,nx,
> ny,0,crevar,1)
write(*,'(a8,a10,a5,a10,a10,f7.2,a2)')
> ' ... ',trim(varname),' -> ',trim(cdfname),
> ' [ time = ',time,' ]'
endif
c Write status information
print*
print*,' *** END OF PROGRAM DENSITY **'
print*,'========================================================='
end
c ********************************************************************
c * GRIDDING SUBROUTINES *
c ********************************************************************
c ---------------------------------------------------------------------
c Gridding of one single data point (smoothing in km, deg, gridp)
c ---------------------------------------------------------------------
subroutine gridding1 (lat,lon,addval,radius,unit,
> connect,connectval,
> out,nx,ny,xmin,ymin,dx,dy)
implicit none
c Declaration of subroutine parameters
real lat,lon
integer nx,ny
real xmin,ymin,dx,dy
real out(nx,ny)
real radius
character*80 unit
integer connectval
integer connect(nx,ny)
real addval
c Auxiliary variables
integer i,j,k
integer mu,md,nr,nl,n,m
integer stackx(nx*ny),stacky(nx*ny)
integer tab_x(nx*ny),tab_y(nx*ny)
real tab_r(nx*ny)
integer sp
real lat2,lon2
real dist,sum
real xmax
integer periodic
integer test
c Numerical epsilon
real eps
parameter (eps=0.01)
c Externals
real sdis,weight
external sdis,weight
c Check whether lat/lon point is valid
xmax=xmin+real(nx-1)*dx
if (lon.lt.xmin-eps) lon=lon+360.
if (lon.gt.xmax+eps) lon=lon-360.
if (abs(lat-90).lt.eps) lat=90.
if (abs(lat+90).lt.eps) lat=-90.
if ((abs(lat).gt.(90.+eps)).or.
> (lon.lt.xmin-eps).or.(lon.gt.xmax+eps)) then
print*,'Invalid lat/lon point ',lat,lon
return
endif
c Set flag for periodic domain
if (abs(xmax-xmin-360.).lt.eps) then
periodic=1
else if (abs(xmax-xmin-360+dx).lt.eps) then
periodic=2
else
periodic=0
endif
c Get indices of one coarse grid point within search radius
i=nint((lon-xmin)/dx)+1
if ((i.eq.nx).and.(periodic.eq.1)) i=1
j=nint((lat-ymin)/dy)+1
lat2=ymin+real(j-1)*dy
lon2=xmin+real(i-1)*dx
dist=sdis(lon,lat,lon2,lat2,unit)
if (dist.gt.radius) then
print*,'1: Search radius is too small...'
stop
endif
c Get connected points
k=0
stackx(1)=i
stacky(1)=j
sp=1
do while (sp.ne.0)
c Get an element from stack
n=stackx(sp)
m=stacky(sp)
sp=sp-1
c Get distance from reference point
lat2=ymin+real(m-1)*dy
lon2=xmin+real(n-1)*dx
dist=sdis(lon,lat,lon2,lat2,unit)
c Check whether distance is smaller than search radius: connected
if (dist.lt.radius) then
c Make entry in filter mask
k=k+1
tab_x(k)=n
tab_y(k)=m
tab_r(k)=weight(dist,radius)
c Mark this point as visited
connect(n,m)=connectval
c Get coordinates of neighbouring points
nr=n+1
if ((nr.gt.nx) .and.(periodic.eq.0)) nr=nx
if ((nr.gt.nx-1).and.(periodic.eq.1)) nr=1
if ((nr.gt.nx) .and.(periodic.eq.2)) nr=1
nl=n-1
if ((nl.lt.1).and.(periodic.eq.0)) nl=1
if ((nl.lt.1).and.(periodic.eq.1)) nl=nx-1
if ((nl.lt.1).and.(periodic.eq.2)) nl=nx
mu=m+1
if (mu.gt.ny) mu=ny
md=m-1
if (md.lt.1) md=1
c Update stack
if (connect(nr,m).ne.connectval) then
connect(nr,m)=connectval
sp=sp+1
stackx(sp)=nr
stacky(sp)=m
endif
if (connect(nl,m).ne.connectval) then
connect(nl,m)=connectval
sp=sp+1
stackx(sp)=nl
stacky(sp)=m
endif
if (connect(n,mu).ne.connectval) then
connect(n,mu)=connectval
sp=sp+1
stackx(sp)=n
stacky(sp)=mu
endif
if (connect(n,md).ne.connectval) then
connect(n,md)=connectval
sp=sp+1
stackx(sp)=n
stacky(sp)=md
endif
endif
end do
if (k.ge.1) then
sum=0.
do i=1,k
sum=sum+tab_r(i)
enddo
do i=1,k
out(tab_x(i),tab_y(i))=out(tab_x(i),tab_y(i))+
> addval*tab_r(i)/sum
if ((tab_x(i).eq.1).and.(periodic.eq.1)) then
out(nx,tab_y(i))=out(nx,tab_y(i))+
> addval*tab_r(i)/sum
endif
enddo
else
print*,'2: Search radius is too small...'
stop
endif
end
c ----------------------------------------------------------------------
c Get spherical distance between lat/lon points
c ----------------------------------------------------------------------
real function sdis(xp,yp,xq,yq,unit)
c Calculates spherical distance (in km) between two points given
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
real re
parameter (re=6370.)
real xp,yp,xq,yq,arg
character*80 unit
real dlon
if ( unit.eq.'km' ) then
arg=sind(yp)*sind(yq)+cosd(yp)*cosd(yq)*cosd(xp-xq)
if (arg.lt.-1.) arg=-1.
if (arg.gt.1.) arg=1.
sdis=re*acos(arg)
elseif ( unit.eq.'deg' ) then
dlon = xp-xq
if ( dlon.gt. 180. ) dlon = dlon - 360.
if ( dlon.lt.-180. ) dlon = dlon + 360.
sdis = sqrt( dlon**2 + (yp-yq)**2 )
endif
c Quick and dirty trick to avoid zero distances
if (sdis.eq.0.) sdis=0.1
end
c ----------------------------------------------------------------------
c Weight function for the filter mask
c ----------------------------------------------------------------------
real function weight (r,radius)
c Attribute to each distanc r its corresponding weight in the filter mask
implicit none
c Declaration of subroutine parameters
real r
real radius
c Simple 0/1 mask
if (r.lt.radius) then
weight=exp(-r/radius)
else
weight=0.
endif
end
c ********************************************************************
c * REPARAMETERIZATION SUBROUTINES *
c ********************************************************************
c -------------------------------------------------------------
c Interpolation of the trajectory with a natural cubic spline
c -------------------------------------------------------------
SUBROUTINE curvefit (time,lon,n,
> sptime,splon,spn)
c Given the curve <time,lon> with <n> data points, fit a
c cubic spline to this curve. The new curve is returned in
c <sptime,splon,spn> with <spn> data points. The parameter
c <spn> specifies on entry the number of spline interpolated points
c along the curve.
implicit none
c Declaration of subroutine parameters
integer n
real time(n),lon(n)
integer spn
real sptime(spn),splon(spn)
c Auxiliary variables
real y2ax(n)
real dt
real s
integer i
real order
c Determine whether the input array is ascending or descending
if (time(1).gt.time(n)) then
order=-1.
else
order= 1.
endif
c Bring the time array into ascending order
do i=1,n
time(i)=order*time(i)
enddo
c Prepare the (natural) cubic spline interpolation
call spline (time,lon,n,1.e30,1.e30,y2ax)
dt=(time(n)-time(1))/real(spn-1)
do i=1,spn
sptime(i)=time(1)+real(i-1)*dt
enddo
c Do the spline interpolation
do i=1,spn
call splint(time,lon,y2ax,n,sptime(i),s)
splon(i)=s
enddo
c Change the time arrays back
do i=1,spn
sptime(i)=order*sptime(i)
enddo
do i=1,n
time(i)=order*time(i)
enddo
return
end
c -------------------------------------------------------------
c Basic routines for spline interpolation (Numerical Recipes)
c -------------------------------------------------------------
SUBROUTINE spline(x,y,n,yp1,ypn,y2)
INTEGER n,NMAX
REAL yp1,ypn,x(n),y(n),y2(n)
PARAMETER (NMAX=500)
INTEGER i,k
REAL p,qn,sig,un,u(NMAX)
if (yp1.gt..99e30) then
y2(1)=0.
u(1)=0.
else
y2(1)=-0.5
u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
endif
do 11 i=2,n-1
sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
p=sig*y2(i-1)+2.
y2(i)=(sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+
*1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
*u(i-1))/p
11 continue
if (ypn.gt..99e30) then
qn=0.
un=0.
else
qn=0.5
un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
endif
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
do 12 k=n-1,1,-1
y2(k)=y2(k)*y2(k+1)+u(k)
12 continue
return
END
SUBROUTINE splint(xa,ya,y2a,n,x,y)
INTEGER n
REAL x,y,xa(n),y2a(n),ya(n)
INTEGER k,khi,klo
REAL a,b,h
klo=1
khi=n
1 if (khi-klo.gt.1) then
k=(khi+klo)/2
if(xa(k).gt.x)then
khi=k
else
klo=k
endif
goto 1
endif
h=xa(khi)-xa(klo)
if (h.eq.0.) pause 'bad xa input in splint'
a=(xa(khi)-x)/h
b=(x-xa(klo))/h
y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**
*2)/6.
return
END
c ********************************************************************
c * INPUT / OUTPUT SUBROUTINES *
c ********************************************************************
c --------------------------------------------------------------------
c Subroutines to write the CF netcdf output file
c --------------------------------------------------------------------
subroutine writecdf2D_cf
> (cdfname,varname,longname,unit,gridtype,clon,clat,
> nlonlat,dlonlat,arr,time,dx,dy,xmin,ymin,nx,ny,
> crefile,crevar,cretime)
c Create and write to the CF netcdf file <cdfname>. The variable
c with name <varname> and with time <time> is written. The data
c are in the two-dimensional array <arr>. The list <dx,dy,xmin,
c ymin,nx,ny> specifies the output grid. The flags <crefile> and
c <crevar> determine whether the file and/or the variable should
c be created; correspondingly for the unlimited dimension <time>
c with the flag <cretime>.
USE netcdf
IMPLICIT NONE
c Declaration of input parameters
character*80 cdfname
character*80 varname,longname,unit
integer nx,ny
real arr(nx,ny)
real dx,dy,xmin,ymin
real time
integer crefile,crevar,cretime
character*80 gridtype
real clon,clat
integer nlonlat
real dlonlat
c Local variables
integer ierr
integer ncID
integer LonDimId, varLonID
integer LatDimID, varLatID
integer TimeDimID, varTimeID
real longitude(nx)
real latitude (ny)
real timeindex
integer i
integer nvars,varids(100)
integer ndims,dimids(100)
real timelist(1000)
integer ntimes
integer ind
integer varID
c Quick an dirty solution for fieldname conflict
if ( varname.eq.'time' ) varname = 'TIME'
c Initially set error to indicate no errors.
ierr = 0
c ---- Create the netCDF - skip if <crefile=0> ----------------------
if ( crefile.ne.1 ) goto 100
c Create the file
ierr = nf90_create(trim(cdfname), NF90_CLOBBER, ncID)
c Define dimensions
ierr=nf90_def_dim(ncID,'longitude',nx , LonDimID )
ierr=nf90_def_dim(ncID,'latitude' ,ny , LatDimID )
ierr=nf90_def_dim(ncID,'time' ,nf90_unlimited, TimeDimID)
c Define coordinate Variables
ierr = nf90_def_var(ncID,'longitude',NF90_FLOAT,
> (/ LonDimID /),varLonID)
ierr = nf90_put_att(ncID, varLonID, "standard_name","longitude")
ierr = nf90_put_att(ncID, varLonID, "units" ,"degree_east")
ierr = nf90_def_var(ncID,'latitude',NF90_FLOAT,
> (/ LatDimID /),varLatID)
ierr = nf90_put_att(ncID, varLatID, "standard_name", "latitude")
ierr = nf90_put_att(ncID, varLatID, "units" ,"degree_north")
ierr = nf90_def_var(ncID,'time',NF90_FLOAT,
> (/ TimeDimID /), varTimeID)
ierr = nf90_put_att(ncID, varTimeID, "axis", "T")
ierr = nf90_put_att(ncID, varTimeID, "calendar", "standard")
ierr = nf90_put_att(ncID, varTimeID, "long_name", "time")
ierr = nf90_put_att(ncID, varTimeID, "units", "hours")
c Write global attributes
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'Conventions', 'CF-1.0')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'title',
> 'Trajectory Densities')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'source',
> 'Lagranto Trajectories')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'institution',
> 'ETH Zurich, IACETH')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'grid',trim(gridtype) )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'clon',clon )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'clat',clat )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'nlonlat',nlonlat )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'dlonlat',dlonlat )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'nx',nx )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'ny',ny )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'dx',dx )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'dy',dy )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'xmin',xmin )
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'ymin',ymin )
c Write coordinate data
do i = 1,nx+1
longitude(i) = xmin + real(i-1) * dx
enddo
do i = 1,ny+1
latitude(i) = ymin + real(i-1) * dy
enddo
c Check whether the definition was successful
ierr = nf90_enddef(ncID)
if (ierr.gt.0) then
print*, 'An error occurred while attempting to ',
> 'finish definition mode.'
stop
endif
c Write coordinate data
ierr = nf90_put_var(ncID,varLonID ,longitude)
ierr = nf90_put_var(ncID,varLatID ,latitude )
c Close netCDF file
ierr = nf90_close(ncID)
100 continue
c ---- Define a new variable - skip if <crevar=0> -----------------------
if ( crevar.ne.1 ) goto 110
c Open the file for read(write access
ierr = nf90_open (trim(cdfname), NF90_WRITE , ncID)
c Get the IDs for dimensions
ierr = nf90_inq_dimid(ncID,'longitude', LonDimID )
ierr = nf90_inq_dimid(ncID,'latitude' , LatDimID )
ierr = nf90_inq_dimid(ncID,'time' , TimeDimID)
c Enter define mode
ierr = nf90_redef(ncID)
c Write definition and add attributes
ierr = nf90_def_var(ncID,varname,NF90_FLOAT,
> (/ LonDimID, LatDimID, varTimeID /),varID)
ierr = nf90_put_att(ncID, varID, "long_name" , longname )
ierr = nf90_put_att(ncID, varID, "units" , unit )
ierr = nf90_put_att(ncID, varID, '_FillValue', -999.99 )
c Check whether definition was successful
ierr = nf90_enddef(ncID)
if (ierr.gt.0) then
print*, 'An error occurred while attempting to ',
> 'finish definition mode.'
stop
endif
c Close netCDF file
ierr = nf90_close(ncID)
110 continue
c ---- Create a new time (unlimited dimension) - skip if <cretime=0> ------
if ( cretime.ne.1 ) goto 120
c Open the file for read/write access
ierr = nf90_open (trim(cdfname), NF90_WRITE, ncID)
c Get the list of times on the netCDF file
ierr = nf90_inq_dimid(ncID,'time', TimeDimID)
if ( ierr.ne.0 ) then
print*,'Time dimension is not defined on ',trim(cdfname),
> ' .... Stop'
stop
endif
ierr = nf90_inquire_dimension(ncID, TimeDimID, len = ntimes)
ierr = nf90_inq_varid(ncID,'time', varTimeID)
if ( ierr.ne.0 ) then
print*,'Variable time is not defined on ',trim(cdfname),
> ' ... Stop'
stop
endif
ierr = nf90_get_var(ncID,varTimeID,timelist(1:ntimes))
c Decide whether a new time must be written
ind = 0
do i=1,ntimes
if ( time.eq.timelist(i) ) ind = i
enddo
c Extend the time list if required
if ( ind.eq.0 ) then
ntimes = ntimes + 1
timelist(ntimes) = time
ierr = nf90_put_var(ncID,varTimeID,timelist(1:ntimes))
endif
c Close netCDF file
ierr = nf90_close(ncID)
120 continue
c ---- Write data --------------------------------------------------
c Open the file for read/write access
ierr = nf90_open (trim(cdfname), NF90_WRITE , ncID)
c Get the varID
ierr = nf90_inq_varid(ncID,varname, varID )
if (ierr.ne.0) then
print*,'Variable ',trim(varname),' is not defined on ',
> trim(cdfname)
stop
endif
c Get the time index
ierr = nf90_inq_dimid(ncID,'time', TimeDimID)
if ( ierr.ne.0 ) then
print*,'Time dimension is not defined on ',trim(cdfname),
> ' .... Stop'
stop
endif
ierr = nf90_inquire_dimension(ncID, TimeDimID, len = ntimes)
ierr = nf90_inq_varid(ncID,'time', varTimeID)
if ( ierr.ne.0 ) then
print*,'Variable time is not defined on ',trim(cdfname),
> ' ... Stop'
stop
endif
ierr = nf90_get_var(ncID,varTimeID,timelist(1:ntimes))
ind = 0
do i=1,ntimes
if ( time.eq.timelist(i) ) ind = i
enddo
if (ind.eq.0) then
print*,'Time',time,' is not defined on the netCDF file',
> trim(cdfname),' ... Stop'
stop
endif
c Write data block
ierr = nf90_put_var(ncID,varID,arr,
> start = (/ 1, 1, ind /),
> count = (/ nx, ny, 1 /) )
c Check whether writing was successful
ierr = nf90_close(ncID)
if (ierr.ne.0) then
write(*,*) trim(nf90_strerror(ierr))
write(*,*) 'An error occurred while attempting to ',
> 'close the netcdf file.'
write(*,*) 'in clscdf_CF'
endif
end
c ********************************************************************************
c * Transformation routine: LMSTOLM and PHSTOPH from library gm2em *
c ********************************************************************************
REAL FUNCTION LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C
C**** LMSTOLM - FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C**** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : LAM = LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C** IM ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHIS REAL GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C** LAMS REAL GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C** POLPHI REAL WAHRE GEOGR. BREITE DES NORDPOLS
C** POLLAM REAL WAHRE GEOGR. LAENGE DES NORDPOLS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: D.MAJEWSKI
REAL LAMS,PHIS,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHIS = ZPIR18*PHIS
ZLAMS = LAMS
IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
ZLAMS = ZPIR18*ZLAMS
ZARG1 = SIN(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS) +
1 ZCOSPOL* SIN(ZPHIS)) -
2 COS(ZLAMPOL)* SIN(ZLAMS)*COS(ZPHIS)
ZARG2 = COS(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS) +
1 ZCOSPOL* SIN(ZPHIS)) +
2 SIN(ZLAMPOL)* SIN(ZLAMS)*COS(ZPHIS)
IF (ABS(ZARG2).LT.1.E-30) THEN
IF (ABS(ZARG1).LT.1.E-30) THEN
LMSTOLM = 0.0
ELSEIF (ZARG1.GT.0.) THEN
LMSTOLAM = 90.0
ELSE
LMSTOLAM = -90.0
ENDIF
ELSE
LMSTOLM = ZRPI18*ATAN2(ZARG1,ZARG2)
ENDIF
RETURN
END
REAL FUNCTION PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C
C**** PHSTOPH - FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C**** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C**** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : PHI = PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHIS REAL GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C** LAMS REAL GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C** POLPHI REAL WAHRE GEOGR. BREITE DES NORDPOLS
C** POLLAM REAL WAHRE GEOGR. LAENGE DES NORDPOLS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE BREITE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: D.MAJEWSKI
REAL LAMS,PHIS,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
SINPOL = SIN(ZPIR18*POLPHI)
COSPOL = COS(ZPIR18*POLPHI)
ZPHIS = ZPIR18*PHIS
ZLAMS = LAMS
IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
ZLAMS = ZPIR18*ZLAMS
ARG = COSPOL*COS(ZPHIS)*COS(ZLAMS) + SINPOL*SIN(ZPHIS)
PHSTOPH = ZRPI18*ASIN(ARG)
RETURN
END
REAL FUNCTION LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** LMTOLMS - FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM
C**** AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : LAM = LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM AUF
C** EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHI REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C** LAM REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C** POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C** POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: G. DE MORSIER
REAL LAM,PHI,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHI = ZPIR18*PHI
ZLAM = LAM
IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
ZLAM = ZPIR18*ZLAM
ZARG1 = - SIN(ZLAM-ZLAMPOL)*COS(ZPHI)
ZARG2 = - ZSINPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL)+ZCOSPOL*SIN(ZPHI)
IF (ABS(ZARG2).LT.1.E-30) THEN
IF (ABS(ZARG1).LT.1.E-30) THEN
LMTOLMS = 0.0
ELSEIF (ZARG1.GT.0.) THEN
LMTOLMS = 90.0
ELSE
LMTOLMS = -90.0
ENDIF
ELSE
LMTOLMS = ZRPI18*ATAN2(ZARG1,ZARG2)
ENDIF
RETURN
END
REAL FUNCTION PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** PHTOPHS - FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI
C**** AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : PHI = PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI AUF
C** EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHI REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C** LAM REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C** POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C** POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C** AUSGABE-
C** PARAMETER: ROTIERTE BREITE PHIS ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: G. DE MORSIER
REAL LAM,PHI,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHI = ZPIR18*PHI
ZLAM = LAM
IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
ZLAM = ZPIR18*ZLAM
ZARG = ZCOSPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL) + ZSINPOL*SIN(ZPHI)
PHTOPHS = ZRPI18*ASIN(ZARG)
RETURN
END

/tags/1.0/density/density.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = density.o ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
density: $(OBJS)
${F77} -o density $(OBJS) ${INCS} $(LIBS)

/tags/1.0/density/density.sh
0,0 → 1,257
#!/bin/csh
# ---------------------------------------------------------------------
# Usage, parameter settings
# ---------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( (${#argv} == 0) | (${#argv} < 2) ) then
echo
${LAGRANTO}/bin/lagrantohelp density short
echo
exit 0
endif
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR DENSITY *** '
echo
# ---------------------------------------------------------------------
# Handle input parameters
# ---------------------------------------------------------------------
# Get input parameters
set inpfile = $1
set outfile = $2
# Set default values
set radius = 100
set unit = 'km'
set grid = "360 180 -180. -90. 1. 1."
set mode = 'keep'
set tratime = 'all'
set param = 0
set gridtype = 'latlon'
set sel_file = 'nil'
set sel_format = 'nil'
set field = 'nil'
set crefile = 0
# Handle optional arguments
while ( $#argv > 0 )
switch ( $argv[1] )
case -radius
set radius = $argv[2]
set unit = $argv[3]
echo "Flag '-radius' -> ${radius} ${unit} (user defined)"
shift;
shift;
breaksw
case -time
set tratime=$argv[2]
echo "Flag '-tratime' -> ${tratime} (user defined)"
shift;
breaksw
case -interp
set param=$argv[2]
if ( "$argv[3]" == "h" ) set mode = "time"
if ( "$argv[3]" == "km" ) set mode = "space"
if ( "$argv[3]" == "deg" ) set mode = "grid"
echo "Flag '-interp' -> ${mode} ${param} (user defined)"
shift;
shift;
breaksw
case -create
set crefile = 1
echo "Flag '-create' -> true (user defined)"
breaksw
case -latlon
set gridtype = 'latlon'
if ( "$argv[2]" == "dynamic" ) then
set grid = "0 0 0 0 0 0"
echo "Flag '-latlon' -> dynamic (user defined)"
shift;
else
set nlon = $argv[2]
set nlat = $argv[3]
set lonmin = $argv[4]
set latmin = $argv[5]
set dlon = $argv[6]
set dlat = $argv[7]
set grid = "${nlon} ${nlat} ${lonmin} ${latmin} ${dlon} ${dlat}"
echo "Flag '-latlon -> ${grid} (user defined)"
shift;
shift;
shift;
shift;
shift;
shift;
endif
breaksw
case -rotated
set gridtype = 'rotated'
set clon = $argv[2]
set clat = $argv[3]
set nlonlat = $argv[4]
set dlonlat = $argv[5]
set grid = "${clon} ${clat} ${nlonlat} ${dlonlat}"
echo "Flag '-rotated -> ${clon}, ${clat}, ${nlonlat}, ${dlonlat} (user defined)"
shift;
shift;
shift;
shift;
breaksw
case -index
set sel_file = $argv[2]
set sel_format = 'index'
echo "Flag '-index' -> ${sel_file} (user defined)"
shift;
breaksw
case -boolean
set sel_file = $argv[2]
set sel_format = 'boolean'
echo "Flag '-boolean' -> ${sel_file} (user defined)"
shift;
breaksw
case -field
set field = $argv[2]
echo "Flag '-field' -> ${field} (user defined)"
shift;
breaksw
endsw
shift;
end
# ---------------------------------------------------------------------
# Do some checks and preparation, then run the program
# ---------------------------------------------------------------------
# Rename field <time> to <TIME> to avoid conflict with time coordinate
# on the netCDF file
if ( "${field}" == "time" ) set field = "TIME"
# Determine the time step
if ( "${tratime}" == "all" ) then
set step = 0
else
set timelist = (`${LAGRANTO}/bin/trainfo.sh $inpfile times`)
set step = 0
set found = 0
foreach val ( ${timelist} )
@ step = ${step} + 1
if ( "${tratime}" == "${val}" ) then
set found = ${step}
endif
end
if ( ${found} == 0 ) then
echo "Invalid time ${tratime} for gridding"
echo "${timelist}"
exit 1
endif
set step = ${found}
endif
# Check consistency of arguments
if ( ( "${mode}" == "time" ) & ( ${step} != 0 ) ) then
echo " ERROR: Options 'interp -time' and 'step' incompatible' "
exit 1
endif
if ( ( "${mode}" == "space" ) & ( ${step} != 0 ) ) then
echo " ERROR: Options 'interp -space' and 'step' incompatible' "
exit 1
endif
# Get trajectory info
set ntra = (`${LAGRANTO}/bin/trainfo.sh $inpfile ntra`)
set ntime = (`${LAGRANTO}/bin/trainfo.sh $inpfile ntim`)
set nfield = (`${LAGRANTO}/bin/trainfo.sh $inpfile ncol`)
# Check whether selection file is available
if ( "${sel_file}" != "nil" ) then
if ( ! -f ${sel_file} ) then
echo " ERROR: selection file ${sel_file} is missing... Stop"
exit 1
endif
endif
# Check whether output file exists - set the <crefile> flag
if ( "${crefile}" == "0" ) then
if ( ! -f ${outfile} ) then
set crefile = 1
echo
echo "${outfile} will be created... "
else
echo
echo "${outfile} will be modified ..."
endif
else
echo
echo "${outfile} will be created... "
endif
# Chewck whether the variable exists - set the <crevar> flag
if ( "${crefile}" == "0" ) then
set varlist = ` ${LAGRANTO}/goodies/getvars ${outfile}`
set crevar = 1
foreach var ( ${varlist} )
if ( "${var}" == "${field}" ) set crevar = 0
end
else
set crevar = 1
endif
# Prepare parameter file and run program
\rm -f density.param
touch density.param
echo ${inpfile} >> density.param
echo ${outfile} >> density.param
echo \"${field}\" >> density.param
echo ${ntime} ${nfield} ${ntra} >> density.param
echo ${gridtype} >> density.param
echo ${grid} >> density.param
echo ${radius} ${unit} >> density.param
echo ${mode} >> density.param
echo ${param} >> density.param
echo ${step} >> density.param
echo \"${sel_file}\" >> density.param
echo \"${sel_format}\" >> density.param
echo ${crefile} >> density.param
echo ${crevar} >> density.param
# Write status info
echo
echo ' *** END OF PREPROCESSOR DENSITY *** '
echo '========================================================='
echo
# Run density
${LAGRANTO}/density/density
# Make clean
\rm -f density.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/docu/man/caltra.0
0,0 → 1,97
.TH caltra
.SH NAME
.B caltra -
calculate air parcel trajectories
.SH SYNOPSIS
.B caltra
.I startdate
.I enddate
.I startfile
.I filename
[
.I optional arguments
]
.SH DESCRIPTION
Calculate trajectories for the air parcels starting at the positions specified in
.I startfile.
The trajectories cover the time period from
.I startdate
to
.I enddate
and the trajectories are saved in the output file
.I filename.
Forward and backward trajectories can be calculated according to the order of the start and end date.
.SH PARAMETERS
.TP 15
.I startdate
start time of the air parcels in the format YYYYMMDD_HH(MM) (e.g. 20100101_00 or 20100101_0030 for 1 January 2010, 00 UTC and 00:30 UTC). Note that the minutes (MM) are optional.
.TP 15
.I enddate
end time of the air parcels (same format as the
.I startdate
). If the end time is after the start time, forward trajectories are calculated; otherwise, i.e. for end date before the start date, backward trajectories result.
.TP 15
.I startfile
file with the starting positions of the trajectories (possibly created with
.B
create_strartf
). Different formats for the "startfile" are supported (see
.B reformat
for details). If no format specifier (appendix .[1234]) is given, a simple (longitude,latitude,pressure) list is expected.
.TP 15
.I filename
output trajectory file with trajectories. Different formats are supported (see
.B reformat
for details).
.SH OPTIONAL
.br
.TP 15
.I -j
Jumping flag: if a trajectory crosses the lower boundary, it is raised a little and hence is allowed to move on. Otherwise, i.e. no "-j" flag set, the trajectory would stick at the same position. The default is that "-j" is
.B not
set.
.TP 15
.I -i hours
time increments (in hours) for input P and S files. If not explicitely specified, this is determined from the P and S files in the current directory.
.TP 15
.I -t min
time step (in minutes) for trajcetory calculation. Per default, the time step is 1/12 the time increment of the input files. For instance, 6-h input P and S files result in a time step of 5 min. The time step must be consisten with the output interval (see next optional parameter "-o").
.TP 15
.I -o hours
Output interval (in minutes) of the air parcel positions. Per default it is the same as the time increment between the input P and S files (see option "-i"). Note that the output interval must be a multiple of the time step for trajectory calculation (see optional argument "-t").
.TP 15
.I -p
Periodicity flag. If set, a periodic domain is assumed in zonal direction. Per default, the flag is
.B not
set.
.TP 15
.I -changet
flag whether the times of the P and S files should be changed or not before a calculation; the default is that the
times are
.B not
changed.
.TP 15
.I -noclean
flag whether parameter and criterion files should be kept; this is particularly helpful for debugging.
.TP 15
.I -timecheck
enforce a time check on the data file
.SH EXAMPLES
.TP 5
.B [1] caltra 19891020_00 19891020_18 startf OUT.1
Calculate forward trajectories from 20/10/1989 00 UTC to 20/10/1989 18 UTC. The starting starting positions are given on the file "startf" as a list of (longitude,latitude,pressure) values. The output trajectories are written to the file "OUT.1", where the appendix 1 denotes ASCII format..B
.TP 5
.B [2] caltra 19891020_18 19891020_00 startf OUT.1
As in example 1, but backward trajectories from 20/10/1989 18 UTC to 20/10/1989 00 UTC.
.TP 5
.B [3] caltra 19891020_00 19891020_18 startf OUT -j
As in example [1], but with jumping flag set: if a trajectory crosses the lower boundary (topography), it is raised a little and then is allowed to move on.
.TP 5
.B [4] caltra 19891020_00 19891020_18 startf OUT -j -o 15 -t 15
As in example [3], but the output interval is set to 15 min with the optional argument "-o". Note that the output interval (15 min) must be a multiple of the time step, which is here set explicitely to 15 min with "-t".
.TP 5
.B [5] caltra 19891020_0130 19891020_1730 startf1 OUT -j -o 15 -t 15 -changet
Start from non-analysis time 01:30 UTC to non-analysis time 17:30 UTC. Furthermore, the times on the prinmary netCDF files are changed accordingly.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/changecst.0
0,0 → 1,22
.TH changecst
.SH NAME
.B changecst - change constants file name on the netCDF file
.SH SYNOPSIS
.B changecst
.I filename
.I new_cst_file
.SH DESCRIPTION
Change the name of the constants file for "filename" to the new name "new_cst_file"
.SH PARAMETERS
.TP 15
.B filename
name of the netCDF file
.TP 15
.B new_cst_file
name of the new constants file name
.SH EXAMPLES
.TP 5
.B [1] changecst P20110102_18 ml_cst
change the constants filename for P20110102_18 to its new name "ml_cst".
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/changet.0
0,0 → 1,22
.TH changet
.SH NAME
.B changet - change time on a netCDF file with filename P{YYYYMMDD_HH} or S{YYYYMMDD_HH}
.SH SYNOPSIS
.B changet
.I startdate
.I file
.SH DESCRIPTION
Change the time value of a netCDF file with filename P{YYYYMMDD_HH} or S{YYYYMMDD_HH}; the time is set in hours relative to the startdate (in format YYYYMMDD_HH).
.SH PARAMETERS
.TP 15
.B startdate
reference date in format YYYYMMDD_HH.
.TP 15
.B file
name of the netCDF file with filename P{YYYYMMDD_HH} or S{YYYYMMDD_HH}.
.SH EXAMPLES
.TP 5
.B [1] changet 20110102_00 P20110102_18
sets the time of the netCDF file "P20110102_18" to 18 h.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/create_startf.0
0,0 → 1,195
.TH create_startf
.SH NAME
.B create_startf -
create starting files for Lagranto
.SH SYNOPSIS
.B create_startf
.I date
.I filename
.I specifier
[
.I optional arguments
]
.SH DESCRIPTION
Create starting files
for a Lagranto calculation. The staring positions are based on the P and S files for
.I date
and are as specified in a
.I specifier.
The starting coordinates (longitude, latitude, pressure [in hPa]) are written to the file
.I filename.
.SH PARAMETERS
.TP 15
.I date
date of input P and S file (e.g. 20100101_00). If the date is between two P and S files,
linear interpolation is used between the two times.
.TP 15
.I filename
output file with starting points (e.g. startf). Different formats are supported (see
.B reformat
for details)
.TP 15
.I specifier
detailed description of starting positions. The specifier has the following format:
.B
.I <horizontal>
@
.I <vertical>
@
.I
<unit>
@
.I <selection>.
The components of the specifier are described in greater detail in the following sections.
.SH HORIZONTAL
.TP 15
.B - file[filename]
read lon/lat from file "filename"; each line contains one lat/lon pair.
.TP 15
.B - line[lon1,lon2,lat1,lat2,n]
n points from (lon1,la1) to (lon2,lat2); the points are linearly interpolated in lat/lon space.
.TP 15
.B - box.eqd[lon1,lon2,lat1,lat2,ds]
lat/lon box bounded with south-western point (lon1,lat1) and north-eastern point (lon2,lat2); the equdistant points within the box have a horizontal distance ds (in [km]).
.TP 15
.B - box.grid[lon1,lon2,lat1,lat2,]
lat/lon box with south-western point (lon1,lat1) and north-eastern point (lon2,lat2 grid points; all grid points within this box are taken as staring points.
.TP 15
.B - point[lon,lat]
single lon/lat point.
.TP 15
.B - shift[lon,lat,dlon,dlat]
lon/at points and dlon/dlat shifhted ones, i.e. in total five points: central one and four shifted ones: (lon,lat), (lon+dlon,lat), (lon-dlon,lat), (lon,lat+dlat), (lon,lat-dlat).
.TP 15
.B - polygon.eqd[filename,ds]
equidistant within arbirtrary polygon (ds in [km]). The file with the polygon points has the following format: 1st line a lon/lat point within the polygon; further lines lon/lat points of the vertices (max 500) of the polygon.
.TP 15
.B - polygon.grid[filename]
grid points within arbirtrary polygon. The file with the polygon points has the following format: 1st line a lon/lat point within the polygon; further lines lon/lat points of the vertices (max 500) of the polygon.
.TP 15
.B - circle.eqd[lonc,latc,radius,ds]
circle with centre at (lonc,latc) and radius "radius" (in km); the equdistant points within the circle have a horizontal distance ds (in [km]).
.TP 15
.B - circle.grid[lonc,latc,radius]
circle with centre at (lonc,latc) and radius "radius" (in km); all rid points within the circle are selected.
.TP 15
.B - region.eqd[id,ds]
Read region specification from region file ("default regionf", to be changed with option "-regionf") and fill it equidistantly with starting points (ds in km). The region identification is "id", see below in section REGION FILE.
.TP 15
.B - region.grid[id]
Read region specification from region file ("default regionf", to be changed with option "-regionf") and fill it with starting points on the input grid. The region identification is "id", see below in section REGION FILE.
.SH VERTICAL
.TP 15
.B - file[filename]
read levels from file "filename"; each line in the file contains one level.
.TP 15
.B - level[lev]
a single level
.TP 15
.B - list[lev1,lev2,lev3,...]
a list of levels; if many levels are needed they are better passed to "create_startf" with the option "file[filename]".
.TP 15
.B - profile[lev1,lev2,n]
n equdistant levels between lev1 and lev2.
.TP 15
.B - grid[lev1,lev2]
all grid points within layer (lev1,lev2) are selected
.SH UNIT
.TP 15
.B - hPa
pressure (in hPa).
.TP 15
.B - hPa,agl
pressure (in hPa) above ground level.
.TP 15
.B - K
potential temperature (in K).
.TP 15
.B - PVU
potential vorticty (in PVU). Note that potential vorticity (PV) might not be unique as a vertical coordinate; if several levels have a given PV value, the highest one is chosen.
.TP 15
.B - INDEX
index of model level (1=surface).
.SH SELECTION
.TP 15
.B - criterion
Selection criteria based on meteorological fields applied to the starting position; The criteria follow the syntax of the program
.B select.
.TP 15
.B - nil
If no selection criteria should be invoked, the argument "nil" should be given.
.SH REGION FILE
Several starting regions can be defined for every case in a region file (default filename is "regionf"; to be changed with optional parameter "-regionf filename"). There are two possible formats for specifying a region (they require either a line with 5 or 9 entries):
.TP 5
.B "regnum lonw lone lats latn"
a regular latitude-longitude square: regnum=integer region number; lonw=westernmost longitude of starting region; lone=easternmost longitude; lats=southernmost latitude; latnNorthernmost latitude.
.TP 5
.B "regnum lon1 lat1 lon2 lat2 lon3 lat3 lon4 lat4"
an irregular latitude-longitude square: regnum=integer region number; lon{x},lat{x} = longitude and latitude of the x-th corner. Note that the 4 corners must be arranged counterclockwise. For a triangle the 4th corner can be specified identically to the 3rd.
.TP 5
.B Note: (1) if a line starts with '#' it is regarded as comment and not further considered; (2) each line in the region file must start with '"!
.TP 5
.B "101 -40. -24. 52. 60.":
region in the central Atlantic from 40 W to 24 W and 52 N to 60 N; the region identifier is 101.
.TP 5
.B "250 -30. 43. -24. 36. -18. 50.2 -35.2 50.2":
irregular square in the central Atlantic; the region identifier is 250.
.SH OPTIONAL
.br
.TP 15
.I -t tracefile
tracing file with variables for selection criteria (see
.B trace
for format of the file). If no file is specified, the default
"tracevars" is used. Further, if no selection criterion is invoked, no
tracing file is necessary.
.TP 15
.I -changet
flag whether the times of the P and S files should be changed or not before a calculation; the default is that the
times are not changed.
.TP 15
.I -noclean
flag whether parameter and criterion files should be kept; this is particularly helpfuld for debugging.
.TP 15
.I -regionf filename
change the region file from its default value "regionf" to a new file name: the syntax is "-regionf filename".
.TP 15
.I -timecheck
enforce a time check on the data files
.SH EXAMPLES
.TP 5
.B [1] create_startf 19891020_00 startf 'point(-10,50) @ list(450,500,550) @ hPa'
Starting points are (longitude, latitude, pressure in hPa): (-10,50,450); (-10,50,500); (-10,50,550). No selection criterion is applied; the positions are written to file "startf".
.TP 5
.B [2] create_startf 19891020_00 startf 'line(-10,-5,40,50,10) @ level(450) @ hPa,agl'
10 points are equidistantly specified between lon/lat point (-10,40) and (-5,50); all trajectories start at 450 hPa above ground level - the surface pressure is taken from the primary file P19891020_00. The positions are saved in "startf".
.TP 5
.B [3] create_startf 19891020_00 startf 'box.grid(-10,-5,40,50) @ list(300,320) @ K'
All grid points in the box with the south-eastern lon/lat point (-10,40) and the north-eastern one (-5,50) are taken - the horizontal grid spacing is specfified in the primary file P19891020_00. In the vertical, two isentropic levels are chosen: 300 K and 320 K. The potential temperature for the calculation is taken from the secondary file S19891020_00.
.TP 5
.B [4] create_startf 19891020_00 startf 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa'
A profile of 100 equidistant levels between 1000 hPa and 200 hPa; in the horizontal the central lon/lat point (-10,40) is taken and four horizontally displaced ones, the diplacement being 1 degree in zonal and meridional direction.
.TP 5
.B [5] create_startf 19891020_00 startf.1 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa'
As in the previous example [4], but the starting positions are saved as a trajectory file instead of a (lon,lat,p)-list.
.TP 5
.B [6] create_startf 19891020_00 startf.1 criterion
As in the previous example [5], but the criterion is saved on a file with filename "criterion".
.TP 5
.B [7] create_startf 19891020_00 startf 'polygon.grid(polygon) @ level(500) @ hPa
A polygon is specified in the file "polygon"; the different lines in the file are: -5. 45. / -10. 40. / 10. 40. / 10 50. / -10. 45. The first lon/lat point lies within the polygon, all other lon/lat points are the vertices of the polygon. All grid points within the polygon are taken as starting point, at level 500 hPa.
.TP 5
.B [8] create_startf 19891020_00 startf 'polygon.eqd(polygon,50) @ level(500) @ hPa
As in the previous example [7], except that the starting points are distributed equidistantly within the polygon. The horizontal distance between the starting points is 50 km in zonal and meridional direction.
.TP 5
.B [9] create_startf 19891020_00 startf 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa @ GT:TH:310'
As in example [4], but a selection criterion is additionally applied: only starting positions with potential temperature (TH) greater than (GT) 310 K are kept. Potential temperature must be available on the secondary file S19891020_00 and the file "tracevars" must have a line with "TH 1. 0 S". Further examples for selection criteria can be seen in
.B
select.
.TP 5
.B [10] create_startf 19891020_00 START.1 'region.eqd(3,10) @ level(500) @ hPa'
get equidistant starting points (10 km distance) in the region with identifier 3, as listed in the region file "regionf" (the default).
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/datelist.0
0,0 → 1,79
.TH datelist
.SH NAME
.B datelist - handling of datelists
.SH SYNOPSIS
.B datelist
.I filename
.I mode
.I [ parameters ]
.SH DESCRIPTION
A date list is a file of dates in the format {YYYYMMDD_HH}, e.g. 19900101_00 for 00 UTC, 1 January 1990. This command offers several ways how to create date lists and to work with them.
.SH PARAMETERS
.TP 10
.I filename
name of the date list file. If the name
.B 'stdout'
or
.B 'screen'
is given, the output will be directed to standardoutput: no file will be created.
.TP 10
.I mode
one of several modes (see below).
.SH CREATING DATE LISTS
.TP 5
.B -create stardate enddate
create a datelist from startdate (in format {YYYYMMDD_HHMM}) to enddate; the time interval is per default 6 h (see option -interval). If the start and end date do not match with the analysis times, the date list will contain the enclosing analysis times: for instance, for
.B -create 20100201_04 20100201_19
the date list will contain the following dates: 20100201_00, 20100201_06, 20100201_12, 20100201_18, 20100202_00.
.TP 5
.B -indir dirname
search for dates (in format {YYYYMMDD_HH}) in the direcory given with {dirname} - the dates are written in ascending order to the datelist file and repeating dates are removed.
.TP 5
.B -interval value
change the interval to {value} hours, instead of the default 6 hours.
.SH INFO ABOUT DATE LISTS
.TP 5
.B -ndates
write the number of dates in the list
.TP 5
.B -timerange
write the time range {last date} - {first date} [in hours].
.TP 5
.B -isin date
check whether the date is in the list (1) or not (0).
.SH STEPPING THROUGH DATE LISTS
.TP 5
.B -first
write the first date of the date list
.TP 5
.B -last
write the last date of the date list
.TP 5
.B -next date
find the date {date} in the list and write the
.B next
date to screen; if no next date is in the list, i.e. the end of the list is reached, 'nil' will be returned.
.TP 5
.B -prev date
find the date {date} in the list and write the
.B previous
date to screen; if no previous date is in the list, i.e. the beginning of the list is reached, 'nil' will be returned.
.SH COMPARING DATE LISTS
.TP 5
.B -overlap file1 file1
determine the overlap of two date lists.
.TP 5
.B -onlyin1 file1 file1
determine the dates which only occur in date list 1, but not in datelist 2
.TP 5
.B -onlyin2 file1 file1
determine the dates which only occur in date list 2, but not in datelist 1
.SH Examples
.TP 5
.B [1] datelist screen -indir ./
look for dates in the current directory and write them to screen
.TP 5
.B [2] datelist dates -create 19890101_00 20110101_00 -interval 2
creates dates from 00 UTC, 1 January 1989 to 00 UTC, 1 January 2011 with an interval of 2 hours. The output will be written to the file 'dates'.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/density.0
0,0 → 1,125
.TH density
.SH NAME
.B density -
gridding of trajectory files: either single trajectories or trajectory densities
.SH SYNOPSIS
.B density
.I inpfile
.I outfile
[
.I optional arguments
]
.SH DESCRIPTION
Gridding of a trajectory file "inpfile"; the output is written to a netCDF file "outfile). The trajectories can be interpolated to equal-distance intervals or to a higher time resolution; furthermore, an interpolation is provided to give a continuous line in a longitude/latitude grid. Besides densities of trajectories, possibly at different times, gridding of traced meteorological fields is accepted.
.SH PARAMETERS
.TP 15
.B inpfile
input trajectory file (in one of the accepted formats, see
.B reformat
for details)
.TP 15
.B outfile
output netCDF file with a regular or rotated longitude/latitude grid. The output can be either in IVE or in CF netCDF format (see switches below).
.SH OPTIONAL PARAMETERS
.TP 5
.B - field name
Field name (according to the column names of the trajectory file) which should be gridded. If no field is specified, it is assumed that the trajectory density (counts per grid point) should be gridded.
.TP 5
.B - create
determines the behaviour if the output file already exists: 1) if the file does NOT exist, it will be created; 2) if the file already exists, it will be overwritten, i.e. newly created. If the flag is not set and the file already exists, the output of the new gridding will appended to the existing file. As a typical scenario: density TRAJECTORY DENSITY; density TRAJECTORY DENSITY -field p; density TRAJECORY DENSITY -field PV;... -> all fields (p, PV,...) will be written to the same output file "DENSITY".
.TP 5
.B - index filename
perform only a gridding of the trajectories in the index list "filename"; an index list is just a list of the indices of the single trajectories - it can easily be created with
.B select
and also is used in
.B extract.
.TP 5
.B - boolean filename
perform only a gridding of the trajectories in the boolean list "filename"; a boolean list has for each trajectory an entry 1 (trajectory selected) or 0 (not selected) - it can easily be created with
.B select
and also is used in
.B extract.
.TP 5
.B - interp val unit
interpolate the trajectories to new positions before the gridding; different modes are accepted:
.B 1) "-interp 1 h"
interpolates the trajectories to a new time resolution (here 1 h);
.B 2) "-interp 20 km"
interpolates the trajectories to a new space resolution (here 20 km). Note that nearly stationary trajectories will be reduced in their influence considerably if this mode is applied;
.B 3) "-interp 2 deg"
interpolates to a new resolution, expressed in deg lon/lat. This mode is particularly helpful if a "line" should be drawn on a lon/lat grid.
.TP 5
.B - radius val unit
set the filtering radius for the smoothing (default is 100 km); this radius determines over which radius each trajectory point is smeared out during the gridding. It should be adapted to the grid resolution: if it is too small, and no grid point falls into the circle with this radius, an error message is written. A good choice might be
.B -radius <dlat|dlon [in km]>.
Further Examples:
.B "-radius 2 deg"
for smoothing over 2 degrees lat/lon;
.B "-radius 20 km"
for a 20 km smoothing.
.TP 5
.B - latlon [ nlon nlat lonmin latmin dlon dlat | dynamic ]
specification of the regular output lon/lat grid; the default output grid has parameters: nlon = 360, nlat = 180, lonmin = -180, lonmax = 180, dlon =1, dlat = 1 (global). If the option
.B dynamic
is chosen, the grid is automatically adapted to the trajectory file: the longitude and latitude boundaries are determined and the resulting ranges divided in 400 grid pixel in each direction. In a second step the grid distance is set equal in zonal and meridional direction, and the other grid parameters correspondingly adjusted.
.TP 5
.B - rotated clon clat nlonlat dlonlat
specification of the rotated output lon/lat grid; the centre of the rotated grid is given with the central longitude (clon) and latitude (clat) - this point corresponds to 0/0 in the new coordinate system. The horizontal resolution (dlonlat) of the new grid is equal in rotated longitude and latitude. The final domain extensions are: -(nlonlat-1)/2*dlonlat, +(nlonlat-1)/2*dlonlat and correspondingle for rotated latitude.
.TP 5
.B -time value
do only a gridding of the time specified; e.g. -time 18.00 would perform a gridding of the trajectory time 18 h. If the netCDF already exists, and if the "-create" flag is not set, the new time will be added to the already existing file - the grid parameters will automatically be taken from the netCDF file.
.SH OUTPUT FIELDS
.TP 5
.B - COUNT
number of trajectory points attributed to grid points; the integration of this field over the whole domain is equal to the total number of gridded trajectory points, i.e. equal to the product #trajectories x #times.
.TP 5
.B - RESIDENCE
residence time of trajectory points attributed to grid points; the integration of this field over the whole domain is equal to the total time of all trajectories, i.e. equal to the product #trajectories x #time x time interval.
.TP 5
.B - AREA
area (in square kilometers) attributed to each grid point, i.e. dlat x dlon x coslatitude). This field can be used to convert the units of COUNT and RESIDENCE to grid-independent values. For instance,
.B RESIDENCE/AREA
is the residence time per square kilometer.
.TP 5
.B - FILED
gridded field: e.g gridded pressure, temperature, potential vorticity.
.SH EXAMPLES
.TP 5
.B [1] density TRAJECTORY DENSITY
bring the TRAJECTORY file into a netCDF file DENSITY with gloabl coverage (longitude/latitude grid). The netCDF file is in CF format and the all trajectory points are gridded, based on a smoothing radius of 100 km.
.TP 5
.B [2] density TRAJECTORY DENSITY -latlon dynamic
as in example [1], but now the lon/lat grid is automatically adapted to the range of the trajectory file.
.TP 5
.B [3] density TRAJECTORY DENSITY -interp 1 h
as in exaxmple [1], but the trajectories are interpolated to a 1-h time interval. This gives smoother trajectories.
.TP 5
.B [4] density TRAJECTORY DENSITY -interp 20 km
as in exaxmple [1], but the trajectories are interpolated to a 20-km distance interval.
.TP 5
.B [5] density TRAJECTORY DENSITY -interp 1 deg
as in exaxmple [1], but the trajectories are interpolated to a 1 deg distance interval. If the output grid (as specified in option "-latlon" or "-rotated") has the same spacing (1 deg) as given in "-interp 1 deg", a continuous line is drawn.
.TP 5
.B [6] density TRAJECTORY DENSITY -radius 100 km
the trajectory points are spread out over a circle with radius 100 km; this is equivalent to a smoothing of the resulting density field. Note that in a equidistant cylindrical projection, the circles become distorted towards the pole. If this is not appropriate, the option
.B "-radius 2 deg"
can be given, which is independent of geographical latitude.
.TP 5
.B [7] density VALID DENS -time 18.00
only gridding of the trajectory points corresponding to time 18 h; if no time is specified or if
.B "-time all",
then all trajectory times are included. Note that interpolation with "-interp" (see above) is not allowed, if only one time step is selected, i.e. "-interp" works only with "-time all".
.TP 5
.B [8] density TRAJECTORY DENSITY -rotated 30 50 401 0.1 -interp 0.2 deg
all trajectory times are gridded, but this time onto a rotated lon/lat grid; for instance, an interesting feature was found at (lon=30,lat=50). The new coordinate system, a rotated lon/lat grid, is centered at this point and spreads from 20 W to 20 W and from 20 S to 20 N, comprising 401 grid points in rotated longitude and latitude direction. The new grid resolution is 0.1 degrees, which was taken into account in the interpolation to 0.2 deg intervals between trajectory points.
.TP 5
.B [9] density TRAJECTORY DENSITY -index filename
all trajectories in the trajecrtory file TRAJECTORY are gridded which are listed in the index file "filename".
.TP 5
.B [10] density TRAJECTORY DENSITY -field p -time 0.00 -latlon dynamic
in addition of positional gridding (COUNT, RESIDENCE), do also a gridding of the pressure (p). This gives the pressure at the grid points, averaged over all trajectories passing over the grid point.
.TP 5
.B [11] density TRAJECTORY DENSITY -time 0.00; density TRAJECTORY DENSITY -time 6.00
the trajectory density for "TRAJECTORY" is first written to "OUTPUT" for time 0; then, with the second call, the densities are written for the time 6 h and included into the already existing netCDF file "DENSITY". Similarly, additional fiels can be added to a already existing netCDF file, e.g. with the second call "density TRAJECTOR DENSITY -field p -time 0.00".
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/difference.0
0,0 → 1,41
.TH difference
.SH NAME
.B difference - calculate the difference of two trajecrtory files
.SH SYNOPSIS
.B difference
.I inpfil1
.I inpfile2
.I outfile
.I field
.I [ -single|-max ]
.SH DESCRIPTION
Calculate the difference of two trajectory files "inpfile1" and "inpfile2" and write it to a new trajectory file "outfile". The difference is calculated of the field "field", which must be available on both input files. If the field "LATLON" is specified, the spherical distance between the two trajectories is taken. Furthermore, with "-single" the difference is written at all times, with "-max" only the time of maximum difference is written.
.SH PARAMETERS
.TP 15
.I inpfile1
first trajectory file
.TP 15
.I inpfile2
second trajectory file
.TP 15
.I outfile
output trajectory file - note that this is not a standard trajectory file which can be further processed! The position of both trajectories are listed and also the field for both trajectories and their difference.
.TP 15
.I field
Name of field for which the difference should be calculated. It must be available in both trajectory files. IF "LATLON" is specified, the spherical distance between the trajectory positions is calculated.
.SH OPTIONAL PARAMETERS
.TP 15
.I -single
the difference is written to "outfile" for all trajectory times
.TP 15
.I -max
the difference is written to "outfile" only for the trajectory time with maximum difference.
.SH EXAMPLES
.TP 5
.B [1] difference tra1 tra2 out LATLON -single
gives the speherical distance (LATLON) between trajectories in "tra1" and "tra2". The difference is written for all trajectory times.
.TP 5
.B [2] difference tra1 tra2 out TH -max
gives the difference of potential temperature (TH) between trajectory file "ra1" and "tra2" and writes the maximum difference ("-max") to the output file "out".
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/extract.0
0,0 → 1,55
.TH extract
.SH extract
.B extract - extract columns, times, single trajectories and starting positions
.SH SYNOPSIS
.B extract
.I inptra
.I outtra
.I mode
.SH DESCRIPTION
Extract columns, times, single trajectories or starting positions from an input trajectory file
.I inptra
and write output to a new trajectory file
.I outtra.
The different extraction modes are specified with
.I mode.
Note: the time, longitude, latitude and pressure need not be extracted beacuse they are an integral part of every trajectory file - they are extracted by default.
.SH EXTRACTION MODE
.TP 5
.B -var
extract columns of a trajectory file; the columns can be listed by name (e.g. -var TH PV RH) or a range of columns can be specified by the "to" operator (e.g. -var TH to PV). The two modes can also be combined: "-var TH to PV RH" extracts all columns between TH and PV, and additionally RH.
.TP 5
.B -time
extract trajectory times; the times can be given as a list of times (e.g. -time 6 12) or as a time range (e.g. -time 6 to 18).
.TP 5
.B -tra
extract single trajectories; the index of the trajectories can be specified as a list (e.g. -tra 10 12 14) or as a range of trajectories (e.g. -tra 10 to 20).
.TP 5
.B -startf
extract list (longitude, latitude, pressure) of starting positions ofvthe trajectory file (corresponding to time 0).
.TP 5
.B -index
extract single trajectories - the trajectory indices (from 1 to #trajectories) are given on a file (e.g. -index filename).
.TP 5
.B -boolean
extract single trajectories - the trajectory are specified on a boolean (0/1) file (e.g. -boolean filename).
.TP 5
.B -pattern
extract all trajectories which match the pattern given; the pattern is a list of numbers. It is then checked whether
these numbers occur in a trajectory (all at one time).
.SH EXAMPLES
.TP 5
.B [1] extract inptra outtra -time 6 to 36 72
read input trajectory file "inptra", extract times 6 to 36 and additionally time 72, and write output to trajectory file "outtra".
.TP 5
.B [2] extract inptra outtra -index indfile
reads input trajectories from "inptra" and write all trajectories to "outtra" which are listed in the file "indfile". In "infile" the indices of selected trajectories are listed line-by-line.
.TP 5
.B [3] extract inptra outtra -pattern -999.99
extracts all trajectories which have a missing data (-999.99) entry.
.TP 5
.B [4] extract inptra outtra -pattern 0.00 -44.25 -28.47 140
extracts all trajectories which have the numbers '0.00 -44.25 -28.47 140' in their list. This options
is convenient to search for specific times and positions, and then to see the complete trajectory.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/futureplans.0
0,0 → 1,55
.TH development
.SH NAME
future plans for Lagranto
.SH MAJOR
.TP 5
.B [1] CF netCDF [until 1 April 2011]
interface to CF netCDF format
.TP 5
.B [2] GRIB
interface to GRIB format
.TP 5
.B [3] box tracing
Instead of tracing point meteorological fields, trace the mean,maximum, minimum, median, variance,... within a box around the trajectory position
.TP 5
.B [4] stochastic trajectories
allow in caltra the addition of a random noise to the velocities; option "-random 0.01" would allow random variations of U, V and OMEGA in the range of 1 %. As a further step, a physical based "parameterisation" of turbulence could be included (based on Ri, DEF, TKE,...). This would allow to calculate an ensemble of trajectories, e.g. for one receptor point.
.TP 5
.B [5] Parallelisation
parallelisation of caltra, and possibly also of trace and select.
.TP 5
.B [6] webLagranto
web interface to Lagranto - in analogy to the HYSPLIT model
.TP 5
.B [7] cosmoLagranto
new version of COSMO Lagranto
.SH MINOR
.TP 5
.SH [1] SPECIAL
remeber the settings for a SPECIAL command in the parameter list; this will make the evaluation of SPECIAL commands more efficient.
.TP 5
.SH [2] offset in K
allow vertical offsets in K for tracing, e.g. 'PV:+5K' traces PV 5 K above the trajectory position
.TP 5
.B [3] SPECIAL:STE
special criterion for STE, STT and TST in the form SPECIAL:STE:380,2,0,24,48; tropopause 2 PVU/380 K, STE within time 0-24 h, residence before and after the exchange at least 48 h.
.TP 5
.B [4] compact data format
additional formats for trajectory files: 1) compressed format; 2) FLEXPART format.
.TP 5
.B [5] Goody: residence
calculate the residence time in a specified region for all trajectories in a file
.TP 5
.B [6] Goody: distance
calculate the mimimum distance from a lon/lat/p point for all trajectories in a file.
.TP 5
.B [6] Extension of Lagranto run
extend forward and backward in time an existing Lagranto run
.TP 5
.B [7] Definition of polygons
Matlab tool for the definition of polygon files.
.TP 5
.B [8] datelist
Goody for handling of datelists: 1) datelist file -create start end; 2) datelist file -len; 3) datelist file -first|last; 4) datelist file -sort; 5) datelist file1 file2 -onlyin1|onlyin2|overlap|difference
.SH REPORT FOR NEW IDEAS
Please report new ideas to <michael.sprenger@env.ethz.ch>.

/tags/1.0/docu/man/getmima.0
0,0 → 1,32
.TH getmima
.SH NAME
.B getmima - get the mimimum and maximum of a field on a netCDF file, interpolated either to a pressure or an isentropic surface.
.SH SYNOPSIS
.B getmima
.I filename
.I field
.I [ Pval | Tval ]
.SH DESCRIPTION
Interpolate the field "field" of a netCDF file "filename" either onto a pressure surface "Pval" or onto an isentropic surface "Tval", where the level is given in hPa or K, respectively. The output is in the format: min.max, lonmin, latmin, pmin, tmin, lonmax, latmax, pmax, tmax.
.SH PARAMETERS
.TP 15
.B filename
input netCDF file (e.g. P20110102_00)
.TP 15
.B field
name of the field on the netCDF file (as obtained from
.B getvars).
.TP 15
.B Pval
specification of a pressure surface at height "val" in hPa (e.g. "P500" for 500 hPa).
.B Tval
specification of an isentropic surface at height "val" in K (e.g. "T320" for 320 K).
.SH EXAMPLES
.TP 5
.B [1] getmima P20110201_00 T P500
gives the mimimum and maximum temperature on the 500 hPa surface - the output is: -49.155 -2.606 80.00 -88.00 500 0.0 -143.00 9.00 500 0.0, i.e. the minium temperture is -49.155 deg C at (lon,lat,p,time)=(80, -88, 500, 0) and correspondingly for the maximum temperature.
.TP 5
.B [2] getmima S20110201_00 PV P320
gives the minium and maximum potential vorticity (PV) on the 320-K isentropic surface.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/getmima.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/man/gettidiff.0
0,0 → 1,22
.TH gettidiff
.SH NAME
.B gettidiff - get the difference (in hours) between two dates
.SH SYNOPSIS
.B gettidiff
.I date1
.I date2
.SH DESCRIPTION
Get the time difference (in hours) between two dates ( in form YYYYMMDD_HH(MM), i.e. the minutes are optional): date1 - date2. The output is in format HH or HH.MM
.SH PARAMETERS
.TP 15
.B date1
first date ( in form YYYYMMDD_HH(MM) )
.TP 15
.B date2
second date ( in form YYYYMMDD_HH(MM) )
.SH EXAMPLES
.TP 5
.B [1] gettidiff 20110102_18 20110205_00
gives the time difference between 20110102_18 and 20110205_00; the result is -798 h.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/getvars.0
0,0 → 1,18
.TH getvars
.SH NAME
.B getvars - get a list of a fields on a netCDF file
.SH SYNOPSIS
.B getvars
.I filename
.SH DESCRIPTION
Get a list of all fields on a netCDF file - the names of the fields are listed line-by-line.
.SH PARAMETERS
.TP 15
.B filename
name of the netCDF file (e.g. P20110102_00).
.SH EXAMPLES
.TP 5
.B [1] getvars P20110102_00
gives a list of all fields on the netCDF file P20110102_00; the results is: time, Q, LWC, IWC, T, U, V, OMEGA, PS, SLP
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/lagranto.0
0,0 → 1,180
.TH lagranto
.SH NAME
.B lagranto -
master script for a trajectory calculation, including definition of the starting positions, tracing of meteorological fields and selection of trajectories
.SH SYNOPSIS
.B lagranto
.I caseid[.label]
.I startdate
.I enddate
.I startf
.I select
.I [ optional flags ]
.SH DESCRIPTION
Calculate trajectories for the time period
.I startdate
to
.I enddate
for the starting positions given in
.I
startf,
either as position file or as criteria for starting positions. Furthermore, some selection criteria can be applied to the trajectory file, as given either in a selection file or an explicit seclection criterion (given in
.I select
). Each tracjectory calculation is given a case identifier
.I caseid
which determines where the input data and output files are located.
.SH PARAMETERS
.TP 10
.B caseid
identifier for a trajectory calculation; "caseid" determines where the input netCDF files are found and where the output trajectory file is written. The different options are:
.B 1) local
(the input P and S files must be ready in the directory where Lagranto is called; the output directory is also written to the local directory);
.B 2) casename
(the input files are found in "${HOME}/cdf/casename/" and the output is written to "${HOME}/tra/casename/";
.B 3) interim
(the input files are taken from the ERA-Interim archive, the output is written to the local directory);
.B 4) analysis
(as in 3), but for the ECMWF operational analysis);
.B 5) forecast
(as in 3), but for the ECMWF deterministic forecast).
.TP 10
.B caseid.label
the specification of "label" is optional; it allows to attribute to the output directory name this label and hence to distinguish between several Lagranto runs. Note that "label" has no influence where the input files are found and where the output directory is writtem to. It only is added to the output directory name!
.TP 10
.B startdate
starting date for the trajectory calculation in format YYYYMMDD_HH(MM). This date defines the reference date and time for the trajectory output, i.e. it corresponds to time 0.
.TP 10
.B enddate
end date for the trajectory calculation in format YYYYMMDD_HH(MM); if "enddate" is later than "startdate", a forward trajectory calculation is performed, otherwise a backward calculation. As an example: "20100101_00 20100105_00" is forward, and 20100105_00 20100101_00" is backward in time.
.TP 10
.B startf
definition of the starting positions; they can be either available as a
.B 1) (lon/lat/pressure)-list
in a file; as an
.B 2) explicit criterion
(e.g. "point(50,40) @ list(100,200,300,400) @ hPa') - for details, see documentation of
.B startf;
or as
.B 3) a single point
in the format "longitude latitude pressure".
.TP 10
.B select
definition of selection criterion; it can be passed either in a file or as an explicit selection criterion (e.g. "GT:PV:2:LAST'). For further details, see documentation of command
.B select.
.SH OPTIONAL PARAMETERS
.TP 10
.B -o filename
name of the output trajectory file; default filename is "lsl_{startdate}".
.TP 10
.B -j
jumping flag; if the trajectory runs into the ground, it is lifted a little and allowed to move on. This flag is directly passed to the command
.B caltra.
See documentation for "caltra" for further details.
.TP 10
.B -v tracefile
name of the tracing file which enlists all fields to be traced along the trajectories; the tracing file is directly passed to
.B create_startf
and
.B trace
(see documentation of these two commands for further details).
.TP 10
.B -r regionfile
name of the region file which enlists all regions; the region file is directly passed to
.B create_startf
and
.B select
(see documentation of these two commands for further details).
.TP 10
.B -changet
change the times on the netCDF files relative to the starting date; Lagranto expects the netCDF times to be relative to the starting date. The default value of "-changet" is false.
.TP 10
.B -noclean
do no cleaning after a trajectory run; the default is that the output directory will be cleaned. If cleaning is requested (the default), the following files will be kept in the outputdirectory:
.B 1) the output trajectory file;
.B 2) the log file of the trajectory run;
.B 3) the run script.
All other files are deleted.
.TP 10
.B -log
write log of Lagranto run on screen instead into a file. No log file will be created with this option.
.TP 10
.B -prep
create the run directory, prepare all files and build the run script - but do not run it. Hence, everything is ready for the Lagranto run, but it is not launched. It can be launched manually, possibly after some manual modifications to the run script, with the following steps:
.B 1) change to run directory
(for instance with "lagranto -open caseid.label");
.B 2) start the run script
(with ./runscript.sh, where you have to pass the name of your runscript name).
.SH INPUT FILES
A sucessful Lagranto runs needs several input files; the following list shows all mandatory and optional input files
.TP 10
.B P and S files [mandatory]
input netCDF files; at least the following meteeorological fields must be available on the P files: U=zonal wind [m/s]; V=meridional wind [m/s]; OMEGA=vertical wind [Pa/s]; PS=surface pressure [hPa]. Secondary field can be made available on the S file. Both P and S files have the following format: [P|S]YYYYMMDD_HH, e.g. P20100101_00 for 1st January 2010, 00 UTC.
.TP 10
.B tracevars [optional]
tracing file where all meteorological fields are listed which should be traced along the trajectories. The tracing file is needed by the program
.B create_startf
and particularly
.B trace
(for further details about the format of the file, consider the documentation for these two commands). If no tracing of meteorological fields is needed, no tracing file must be specified. Furthermore, the name of the file can be changed from its default (tracevars) with the optional parameter "-v filename" (see above).
.TP 10
.B regionf [optional]
region specification for definition of strting positions (with
.B create_startf
) or application of Lagrangian selection criteria (with
.B select
). If no region is used in either "select" or "create_startf", no region file must be specified. The name of the region file can be changed from its default (regionf) with the option "-r filename".
.TP 10
.B startf [optional]
definition of the starting positions, either as an explicit list of longitude, latitude, pressure; or as a criterion saved on the file. If the specification of the starting positions is done with an explicit specification in
.B create_startf
(e.g. "point(50,40) @ list(100,200,300) @ hPa") no starting file is needed.
.TP 10
.B select [optional]
definition of a selection criterion for command
.B select.
If the selection criterion is given explicitely in the Lagranto call (e.g. GT:PV:2), no selection file is needed.
.SH OUTPUT FILES AND STRUCTURE
For a Lagranto run a new directory will be created where all needed files are prepared. The name of the directory and the file within it (if cleaning is invoked) are:
.TP 10
.B ntr_${startdate}_{dir}${timerange}_{startf}_{select}
for instance, the Lagranto call "lagranto local 20100101_00 20100102_00 startf selectf" will create the directory "ntr_19891020_00_f24_local_startf_selectf". Correspondingly, for a backward calculation the name would be "ntr_19891021_00_b24_local_startf_selectf", i.e. the {dir} is set to 'b'.
.TP 10
.B ls_${startdate}
default name of the output trajectory file placed in the ntr directory. The name can be changed with the option "-o filename". Note further that different output formats are supported, as described in the documentation for command
.B reformat.
.TP 10
.B runscript.sh
name of the run script, i.e. the script within the ntr directory which calls all Fortran programs. It cn be manually started with "./runscript.sh".
.TP 10
.B runscript.logfile
name of the log file; all status information is written to this file. If a Lagranto run fails, this is the place where to start loking for the reason!
.SH SPECIAL COMMANDS
The main focus of
.B lagranto
is to combine the calls to "create_startf", "caltra", "trace" and "select" into one convenient call. In addition to this, "lagranto" offers some handy special commands which allow more efficient working.
.TP 10
.B -open caseid.label
open a new
.B xterm
window and change to the run directory. If several directories with the same case ID are found, the user is interactively asked to choose one.
.TP 10
.B -remove caseid.label
remove a run directory. If several directories with the same case ID are found, the user is interactively asked to choose one.
.TP 10
.B -show caseid.label
show the contents of the trajectory file as a list. If several directories with the same case ID are found, the user is interactively asked to choose one.
.SH EXAMPLES
.TP 5
.B [1] lagranto local 19891020_00 19891021_00 startf nil -changet
a forward trajectory calculation from 00 UTC, 20 October 2010 to 00 UTC, 21 October 2010. The starting positions are taken from the file "startf". No selection criterion is applied (nil), and the times on the input netCDF files are set relative to the starting date in advance.
.TP 5
.B [2] lagranto local 19891020_00 19891021_00 startf 'GT:PV:2:LAST' -changet
as in example [1], but now an explicit selection criterion is applied (GT:PV:2:LAST) - the potential vorticity at the end date (19891021_00) must be larger than 2 PVU.
.TP 5
.B [3] lagranto local 19891020_00 19891021_00 startf 'GT:PV:2:LAST' -changet -prep
as in the previous two examples, but now only the files and runscript are prepared: no Lagranto run is launched! To do so, you might change to the run directory with
.B lagranto -open local
and then start it manually with
.B ./runscript.sh.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/lagrantohelp.0
0,0 → 1,80
.TH Lagrantohelp
.SH NAME
.B Lagranto -
calculate trajectories for ECMWF analyses and forecasts
.SH SYNOPSIS
.B lagrantohelp [topic|tutorial|reference|future] -
show this man page or the one corresponding to a specific topic. All
.I
underlined
names in this document have their own man page. If "tutorial" is chosen,
a detailed tutorial for Lagranto is opened. For "reference" a PDF document with all man pages is opened. Finally, with option "future" plans for additional features will be listed.
.SH DESCRIPTION
Lagranto is a software tool (UNIX shell-scripts and Fortran programs) to analyze
Lagrangian aspects of atmospheric phenomena. It requires a time-series of
3-dimensional wind fields (and if necessary further variables) on netCDF files.
.SH CORE PROGRAMS
.TP 15
.I create_startf
create starting files
.TP 15
.I caltra
calculate trajectory positions
.TP 15
.I trace
trace meteorological fields along trajectories
.TP 15
.I select
select trajectories based on several criteria
.TP 15
.I density
create netCDF files with trajectory densities
.SH TRAJECTORY TOOLS
.TP 15
.I extract
extract single trajectories, times or columns from a trajectory file
.TP 15
.I list2lsl
transform a (longitude,latitude,pressure) list into a trajectory file
.TP 15
.I lsl2list
transform a trajectory file into a (longitude,latitude,pressure) list
.TP 15
.I mergetra
merge two trajectory files
.TP 15
.I reformat
change the format of a trajectory file
.TP 15
.I timeres
change the time resolution of a trajectory file with interpolation
.TP 15
.I trainfo
write some information about a trajectory file
.TP 15
.I difference
calculate the difference between two trajectory files
.SH NETCDF TOOLS
.TP 15
.I changecst
change the constants filename on a netCDF file
.TP 15
.I changet
change the time on a netCDF file
.TP 15
.I getmima
get the minimum and maximum value of a field on a netCDF file
.TP 15
.I getvars
get a list of fields on a netCDF file
.SH GENERAL TOOLS
.TP 15
.I newtime
get a new date from an initial date and an offset in hours
.TP 15
.I gettidiff
get the time difference between two dates
.SH VISUALISATION
Lagranto comes with two packages for visualisation of trajectories: one based on Matlab (www.mathworks.com) and one based on NCL (www.ncl.ucar.edu). Examples are provided in folder "figure" of the Lagranto installation.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/lidar.0
0,0 → 1,113
.TH trace
.SH NAME
.B lidar - lidar of meteorological fields along trajectories
.SH SYNOPSIS
.B trace
.I inpfile
.I outfile
[
.I optional arguments
]
.SH DESCRIPTION
Get pseudo-lidar of meteorological fields along the trajectories given in the input file
.I inpfile
and write the field to a netCDF file
.I outfile.
The horizontal axis in the netCDF file corresponds to the trajectory times, the vertical axis gives the pressure in hPa (by default, from 100 to 1000 hPa: it can be changet with optional argument '-pmin', '-pmax', '-centering'). By default, the pseudo lidar is taken at a fixed set of pressure levels between 100 and 1000 hPa. If the option '-centering' is selected, the pressure levels are relative to the trajectory position.
The meteorological fields for the pseudo lidar are listed in a
.I
tracing file
(default: tracevars). Note that the tracevars file has the same format as for
.I trace
but that all online calculations in the tracing file are neglected.
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file; the appendix determines the format (see
.B reformat
for details).
.TP 15
.I outfile
output netCDF file for the pseudo-lidar fields.
.SH OUTPUT FIELDS
.TP 5
.B - [ FIELD_SUM | FIELD_MEAN ]
Sum or mean of the lidar field FIELD, depending on the optional parameter '-sum' (default) or '-mean'. For instance, if potential temperature TH is passed as a lidar field, then TH_MEAN would contain the mean over all trajectories. The horizontal axis coincides with the times on the trajectory file; the vertical axis depends on the mode. By default, it goes from 100 hPa to 1000 hPa, within 100 steps. If '-centering' is passed as argument, the pressure levels are always relative to the trajectory position.
.TP 5
.B - FIELD_CNT
Number of values contributing to FIELD_SUM and FIELD_MEAN. This value is variable because the following cases do not contribute to the output field FIELD_SUM/MEAN: (a) if the position is outside the data domain of the input P files; (b) if the position falls below topography; (c) if the trajectory position is invalid; and (d) if the lidar field has a missing value flag set.
.TP 5
.B - POSITION
Position of all trajectories contributing to the lidar composite. By default, the vertical position of the trajectories between 100 hPA and 1000 hPa can be visualised in this way. If '-centering' is selected, the POSITION corresponds to a single line because then all pressure positions are relative to the trajectory height, i.e. a pressure of 0 hPa on tghe vertical axis corresponds to the trajectory position.
.SH TRACING FILE
Normally the meteorological fields for tracing are listed in a file with name
.B "tracevars".
The name of the tracing file can be changed with the optional argument "-v" (see below). The format of the tracing file is as follows:
.br
.TP 5
Format
.I field
.I scale
.I computation
.I prefix
.TP 5
Examples
.B - TH 1. 0 S :
pseudo lidar of potential temperature (TH), scale it with 1 (no scaling); it is available on the S file (no computation is needed: 0).
.br
.B - Q 1000. 0 P :
pseudo lidar of specific humidity (Q), scale it with 1000 to have g/kg; it is available on the P file (no computation is needed: 0).
.SH OPTIONAL ARGUMENTS
.TP 15
.TP 15
.I -i hours
time increments (in hours) for input P and S files. If not explicitely specified, this is determined from the P and S files i
n the current directory.
.TP 15
.I -v varfile
Change the name of the tracing file from its default value "tracevars" to "varfile".
.TP 15
.I -f field scale
Trace field (with scaling scale) along the trajectories; the computation flag and the prefix for the data file is automatically set. This options allows the quick tracing of a field, without specifying a tracing file.
.TP 15
.I -changet
flag whether the times of the P and S files should be changed or not before a calculation; the default is that the
times are
.B not
changed.
.TP 15
.I -noclean
flag whether parameter and criterion files should be kept; this is particularly helpful for debugging.
.TP 15
.I -timecheck
enforce a time check on the data files
.TP 15
.I -nearest
Do no interpolation between grid points; just take the nearest neighbor! This option is useful, if a discrete input field is given (e.g. labels), where interpolated values are meaningless.
.TP 15
.I [-sum|-mean]
If '-sum' (the default) is chosen and several trajectories are on the input file, then the sum of all pseudo lidar fields is written to the output file; otherwise, for '-mean', the mean of all pseudo lidar fields is written.
.TP 15
.I -pmin value
Set the lower pressure limit for the pseudo lidar. Default is 100 hPa.
.TP 15
.I -pmax value
Set the upper pressure limit for the pseudo lidar. Default is 1000 hPa.
.TP 15
.I -npre value
Set the number of pressure levels between 'pmin' and 'pmax. Default is 100.
.TP 15
.I -centering
Select the pressure levels relative to the trajectory position; by default the pressure levels are given as absolute heights between 100 and 1000 hPa. If '-centering' is chosen and no explicit limits are specified with 'pmin' and 'pmax', the limits are set to pmin=-500 hPa and pmax=500 hPa.
.SH EXAMPLES
.TP 5
.B [1] lidar TRAJECTORY.1 LIDAR
Read the trajectory file TRAJECTORY.1 and get a composite pseudo-lidar from 100 to 1000 hPa along the the trajectories. If there are several trajectories on TRAJECTORY.1, the sum is written to the netCDF file LIDAR. The fields of which a pseudo lidar is calculated are listed in the file 'tracevars'.
.TP 5
.B [2] lidar TRAJECTORY.1 LIDAR -pmin 200 -pmax 500
As in [1], but the upper and lower limits of the pseudo lidar are set to 200 and 500 hPa.
.TP 5
.B [2] lidar TRAJECTORY.1 LIDAR -centering
As in [1], but the lidar pressure levels are not fixed: They are taken relative to the trajectory height.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (April 2012).

/tags/1.0/docu/man/list2lsl.0
0,0 → 1,30
.TH list2lsl
.SH NAME
.B list2lsl - convert a list of longitude, latitude and pressure into a trajectory file.
.SH SYNOPSIS
.B list2lsl
.I inpfile
.I outfile
.I [ optional arguments ]
.SH DESCRIPTION
Convert an input file "inpfile" wqith a list of longitude, latitude and pressure into a trajectory file.
.SH PARAMETERS
.TP 15
.I inpfile
input file (a list of longitude, latitude and pressure)
.TP 15
.I outfile
output trajectory file
.SH OPTIONAL PARAMETERS
.TP 5
.B -ref refdate
set the reference date of the trajectory file to "refdate", e.g. "-ref 20110102_00".
.TP 5
.B -time value
set the time of the trajectory file to "value" (in format HH.MM): e.g. "-time 6" sets the time to 6 h.
.SH EXAMPLES
.TP 5
.B [1] list2lsl listfile trafile -refdate 20110101_00 -time 6
converts the list "listfile" into a trajectory file "trafile", where the reference date is 20110101_00 and the time is 6 h.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/lsl2list.0
0,0 → 1,22
.TH lsl2list
.SH NAME
.B lsl2list - convert a trajectory file into a list of longitude, latituden and pressure
.SH SYNOPSIS
.B lsl2list
.I inpfile
.I outfile
.SH DESCRIPTION
Convert an input trajectory file "inpfile" into a list of longitude, latitude and pressure; all times are included in this list.
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file
.TP 15
.I outfile
output file (a list of longitude, latitude and pressure)
.SH EXAMPLES
.TP 5
.B lsl2list trafile listfile
converts all entries of the trajectory file "trafile" into a listfile with longitude, latitude and pressure.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/mergetra.0
0,0 → 1,38
.TH mergetra
.SH NAME
.B mergetra -
combine two trajectory files
.SH SYNOPSIS
.B mergetra
.I inpfile1
.I inpfile2
.I outfile
.SH DESCRIPTION
Combines two input trajectory files "inpfile1" and "inpfile2" and writes a new combined trajectory file "outfile". Three different modes for combination are supported (see below).
.SH PARAMETERS
.TP 15
.I inpfile1
first input trajectory file
.TP 15
.I inpfile2
second input trajectory file
.TP 15
.I outfile
output trajectory file
.SH MODES FOR COMBINATION
Three different combination modes are supported. They are tested for sequentially and the first mode which is accepted, based on the criteria listed below, is performed. The three modes are:
.TP 5
.B - column
The input files have the same trajectory times, longitudes, latitudes and pressures, and both files contain the same number of trajectories. The new trajectory file contains all columns from both input files, duplicate columns only included once, e.g. if "inpfile1" has columns "time,lon,lat,p,TH,PV" and "inpfile2" columns "time,lon,lat,p,PV,Q", the output file will have "time,lon,lat,p,TH,PV,Q".
.TP 5
.B - append
The input files have the same trajectory times and the same columns, but differ in the number of trajectories. Then the second file is appended to the first one and written as a new trajectory file.
.TP 5
.B - times
The input files differ only in the time values, e.g. the first file might contain times -96 h to 0 h and the second the times from 0 h to 96 hours. Then the new combined file will contain the time -96 h to 96 h. Note that duplicate times are eliminated. Furthermore, the output times are sorted in increasing order.
.SH EXAMPLES
.TP 5
.B [1] mergetra file1 file2 newfile
combines the two trajectory files "file1" and "file2" and writes a new trajectory file; the mode for combination is automatically detected.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/newtime.0
0,0 → 1,24
.TH newtime
.SH NAME
.B newtime -
get a new date string from an initial date and an offset in hours
.SH SYNOPSIS
.B newtime
.I date
.I offset
.SH DESCRIPTION
Given an initial date string in format "YYYYMMDD_HH" and an offset in hours, create a new date string - agin in the form "YYYYMMDD_HH".
.SH PARAMETERS
.TP 15
.I date
initial date in form "YYYYMMDD_HH", e.g. 20110102_18 for 18 UTC, 2nd January 2011.
.TP 15
.I offset
Offset in hours; the offset can be positive (into the future) or negative (into the past).
.SH EXAMPLES
.TP 5
.B [1] newtime 20110101_00 45
gives 20110102_21, the datestring 45 h after 20110101_00.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/reformat.0
0,0 → 1,42
.TH reformat
.SH NAME
.B reformat - convert trajectory files between different formats
.SH SYNOPSIS
.B reformat
.I inpfile
.I outfile
.SH DESCRIPTION
Convert a Lagranto trajectory file
.I inpfile
from one format to another format; the new file is written to
.I outfile.
The formats are specified with an appendix to the filename, e.g. "trajectory.1" specifies format 1. If no appendix is given, format 1 is chosen.
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file
.TP 15
.I outfile
output trajectory file (can be the same as inpfile).
.SH FORMATS
Formats must be specified with an appendix to the filename. If no appendix is given, format 1 is chosen.
.TP 5
.B .1
ASCII file; the trajectories are sorted according to their starting positions. Different trajectories are separated by a blank line. This format is the only one supported
by the Matlab and NCL visualisation scripts (see
.B lagrantohelp/visualisation).
.TP 5
.B .2
ASCII file; the trajectories are sorted according to their times. Different times are separated with a blank line.
.TP 5
.B .3
unformatted Fortran; this is the most efficient format, but least portable one.
.TP 5
.B .4
netCDF; portable and compact data format.
.SH EXAMPLES
.TP 5
.B [1] reformat trainp.1 trainp.4
Convert the input trajectory file in format 1 (ASCII) to format 4 (netCDF).
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/select.0
0,0 → 1,289
.TH select
.SH NAME
.B select -
select trajectories
.SH SYNOPSIS
.B select
.I inptra
.I outtra
.I criterion
.SH DESCRIPTION
Select trajectories from the input trajectories in "inptra" based upon meteorological conditions specified in "criterion" (to be described below). The selected trajectories are then written to a new trajectory file "outtra".
.SH PARAMETERS
.TP 15
.I inptra
input trajectory file
.TP 15
.I outtra
output trajectory file
.TP 15
.I criterion
specification of the selection criterion; the specification is either an explicit criterion or a file containing the specification. Each selection criterion has the following form:
.br
.B COMMAND
:
.B FIELD
:
.B ARGUMENTS
:
.B [ TIME ].
.br
Several selection criteria can be combined with logical operator & (AND) and | (OR), the AND having higher priority than the OR.
.SH OPTIONAL ARGUMENTS
.TP 5
.I -noclean
keep temporary files for debugging.
.TP 5
.I -boolean
Write a boolean list (0/1) instead of a trajectory file; the file has #trajectories entries, each line corresponding to an input trajectory /1=trajectory selected, 0=not selected).
.TP 5
.I -index
Write an index list instead of a trajectory file: the index of all selected trajectories is written to the output file - the index ranges from 1 to #trajectories.
.TP 5
.I -count
Write only the number of selected trajectories to the output file.
.TP 5
.I -startf
Write only the starting positions of selected trajectories to the output file.
.TP 5
.I -regionf filename
change the region file from its default value "regionf" to a new file name: the syntax is "-regionf filename".
.SH COMMAND
.TP 5
.B - GT
greater than: e.g.
.B GT:PV:2
selects trajectories with first potential vorticity (PV) larger than 2 PVU.
.TP 5
.B - LT
less than: e.g.
.B LT:RH:70
selects trajectories with first relative humidity (RH) below 70 %.
.TP 5
.B - IN
within: e.g.
.B IN:lon:30,40
selects trajectories with first longitude between 30 and 40 deg.
.TP 5
.B - OUT
outside: e.g.
.B OUT:lat:-30,30
selects trajectories with first latitude outside -30 and 30 deg - neglecting an equatoriual/subtropical band.
.TP 5
.B - EQ
equal: e.g.
.B EQ:p:460
selects trajectories with first pressure equal to 460 hPa.
.TP 5
.B - TRUE
check whether value is different from zero (logical TRUE): e.g.
.B TRUE:CYCL::ALL(ANY)
checks whether the trajectory passes through a cycclone, which is marked as 0/1 field, at any time. Note that the command 'TRUE' has no arguments of its own!
.TP 5
.B - FALSE
check whether value is equal to zero (logical FALSE): e.g.
.B FALSE:CYCL::ALL(ALL)
checks whether the trajectory never passes through a cycclone, which is marked as 0/1 field. Note that the command 'TRUE' has no arguments of its own!
.TP 5
.B - ALL, ANY, NONE
these are special commands which only apply for the TRIGGER field. Further explanations are given below in section TRIGGER.
.SH FIELD
.TP 5
.B - VALUE
take value of the field: e.g.
.B GT:PV(VALUE):2
selects the trajectories with first potential vorticity (PV) value greater than 2 PVU. This selection criterion is equivalent to
.B GT:PV:2,
i.e. the VALUE argument is taken as default.
.TP 5
.B - MEAN
take the mean over the selected times: e.g.
.B GT:RH(MEAN):70:ALL
selects all trajectories for which the mean relative humidity (RH) over all times (ALL) is greater than 70 %.
.TP 5
.B - VAR
take the variance over the selected times: e.g.
.B GT:lat(VAR):10:ALL
selects all trajectories for which the variance of latitude (lat) over all times (ALL) is greater than 10.
.TP 5
.B - MIN
take the minimum of the selected times: e.g.
.B LT:p(MIN):300:ALL
select all trajectories which have a minium pressure (p) less than 300 hPa over all times (ALL).
.TP 5
.B - MAX
take the maximum of the selected times: e.g.
.B LT:p(MAX):300:ALL
select all trajectories which have a maximum pressure (p) less than 300 hPa over all times (ALL).
.TP 5
.B - SUM
take the sum over the selected times: e.g.
.B GT:LHR(SUM):2:ALL
selects all trajectories for which the sum over all latent heating rates (LHR) over all times (ALL) is greater than 2 K.
.TP 5
.B - CHANGE
take change between two times: e.g.
.B GT:p(CHANGE):600:FIRST,LAST
selects all trajectories wich have a pressure difference |p(FIRST)-p(LAST)| greater than 600 hPa between the first and last time or vice versa. Note that the change can be positive or negative, i.e. it is not clear whether it is ascent or descent.
.TP 5
.B - DIFF
take difference between two times: e.g.
.B GT:p(DIFF):600:FIRST,LAST
selects all trajectories wich have a pressure difference p(FIRST)-p(LAST) greater than 600 hPa between the first and last time - corresponding to an ascending air stream. Correspondingly
.B GT:p(DIFF):600:LAST,FIRST
finds a descending air stream.
.SH TIME MODE
The command are applied to a set of trajectory times; if no time is specified, the the command is only applied to the first time. Most generally, the time mode consists of two parts: time list( time mode), where the first specifies a list of times and the second how to apply the criterion to the selected times.
.TP 5
.B - FIRST
first time: e.g.
.B IN:lat:-20,20:FIRST
selects all trajectories with first latitude between 20 S to 20 N, i.e. wich start in an equatorial band.
.TP 5
.B - LAST
last time: e.g.
.B IN:lat:-20,20:LAST
selects all trajectories with last latitude between 20 S to 20 N, i.e. which end in an equatorial band.
.TP 5
.B - T1,T2,T3
an explict list of times: e.g.
.B IN:lat:-20,20:6,12
selects all trajectories which are in the equatorial band at times 6 h and 12 h. The criterion must apply at both times (see below ALL, ANY, NONE).
.TP 5
.B - T1 to T2
a time range: e.g.
.B IN:lat:-20,20:6 to 18
selects all trajectories which are in the equatorial band from 6 h to 18 h. The criterion must apply at all times between 6 h and 18 h (see below ALL, ANY, NONE).
.TP 5
.B - ALL
all times: e.g.
.B IN:lat:-20,20:ALL
selects all trajectories which stay at all times in the equatorial band. This time mode is the same as
.B ALL(ALL),
i.e. all times are selected and the criterion must apply to all times. With
.B IN:lat:-20,20:12-24(ALL)
the criterion must apply for all times between 12 h and 24 h.
.TP 5
.B - ANY
any times: e.g.
.B IN:lat:-20,20:ALL(ANY)
selects all trajectories which stay at any times in the equatorial band. Note that with the first "ALL" the times are selected, i.e. all times in this case, and with the second "ANY" it is specified that the criterion must only apply to at least one of the selected times.
.TP 5
.B - NONE
at no time: e.g.
.B IN:lat:-20,20:ALL(NONE)
selects all trajectories which never stay in the equatorial band.
.B OUT:lat:-20,20:FIRST(NONE)
selects the trajectories which are not outside the equatorial time at the first time: they must be inside.
.TP 5
.B - TRIGGER
the trajectory is automatically selected, but the trigger column is updated. A selection of trajectories might then e accomplished based on this trigger column: e.g
.B GT:p:700:1(TRIGGER)
would set the trigger 1 for all trajectory times where the pressure (p) is greater than 700 hPa. Similarly,
.B GT:p:800:1(TRIGGER) & GT:lat:50:2(TRIGGER)
would set the trigger 1 for all times where the pressure (p) is larger than 800 hPa and set the trigger 2 for all times where the latitude (lat) is larger than 50 degrees north. Note, that both eents might apply: then the rsulting trigger is 3. The triggers are internally saved as the bits of an integer variable, i.e. trigger 1 corresponds to value 1=2^0, trigger 2 to 2=2^1, trigger 3 to 4=2^2...
.SH LOGICAL OPERATORS
.TP 5
.B - &
logical and: e.g.
.B GT:lat:34:FIRST & GT:lon:50:FIRST
selects the trajectories to the north of 34 N and to the east of 50 E at first time. Several selection criteria can be combined with '&'.
.TP 5
.B - |
logical or: e.g.
.B GT:lat:34:FIRST | GT:lon:50:FIRST
selects the trajectories to the north of 34 N or to the east of 50 E at first time. Several selection criteria can be combined with '|'. Note that locical OR has a lower priority than logical AND, i.e. in an expression like T1 | T2 & T3 first the expression T2 & T3 is evaluated and only then logically OR-combined with T1.
.SH IMPLICIT FIELDS
Implicit variables can be used in the selection criteria, although they do not explicitely appear as a column in the trajectory file. They are calculated on-the-fly during the selection.
.TP 5
.B - DIST
length of the trajectory (in km), integrated along great circle sections between the trajectory vertices: e.g.
.B GT:DIST:1000:LAST
tests whether the total path length of the trajectory (DIST) exceeds 1000 km.
.TP 5
.B - DIST0
distance of the trajectory (in km) from its starting position: e.g.
.B GT:DIST0:1000:18,24(ANY)
tests whether the air parcel is more than 1000 km away from its starting position, either at time 18 h or at time 24 h.
.TP 5
.B - INPOLYGON
specification of a polygon: e.g.
.B TRUE:INPOLYGON:filename:ALL(ANY)
selects all trajectories which pass through the polygon specified in "filename". The polygon is specified as described in
.B create_startf
(see comments there). With
.B FALSE:INPOLYGON:filename:ALL(ALL)
all trajectories are selected which never pass through the polygon. Note that for every call of
.B select
only one polygon can be used in the criteria!
.TP 5
.B - INBOX
specification of a longitude/latitude rectangle <lonw,lone,lats,latn>: e.g.
.B TRUE:INBOX:20,40,30,60:ALL(ANY)
selects all trajectories which pass through the longitude/latitude rectangle with lower-left corner at 20 E / 30 N and the upper-right corner at 40 E / 60 N. Correspondingly, with
.B TRUE:INBOX:20,40,30,60:ALL(NONE)
the trajectories are selected which never pass through the rectangle.
.TP 5
.B - INCIRCLE
specification of circle around a specified point: e.g.
.B TRUE:INCIRCLE:40,50,500:LAST
select all trajectories which have their final position (LAST) in the circle centred at 40 E / 50 N and with a radius of 500 km.
.TP 5
.B - INREGION
specification of target regions in a region file (default "regionf") - please consider the documentation of "create_startf" for details concerning the format of the region file. As an example, if a region 1 is defined on the region file, the criterion
.B TRUE:INREGION:1:18
selects all trejactories which are within region 1 at time 18 h.
.SH SPECIAL CRITERIA
Special criteria are and can be implemented into
.B select.
The call to the special criteria is of the following form:
.B SPECIAL:command:parameters,
where "command" is a command string (e.g. WCB) and "parameters" is a list of parameter values.
.TP 5
.B - WCB
identification of Warm Conveyor Belts (WCB): e.g.
.B SPECIAL:WCB:300,0,24
selects trajectories which ascend more than 300 hPa between time 0 and 24 h. Note, the ascent is determined as min{p(0...24)}-p(0), i.e. the first pressure p(0) is fixed whereas the lowest pressure can occur at any time between 0...24 h.
.SH TRIGGER FIELD
A trigger (or flag) field can be defined in select. This special column of the trajectory file allows to mark specified events for each trajectory and its times. As an example, you would like to select all trajectories which are below 700 hPa at a certain time and have relative humidity above 80 %
.B at the same times:
Then you could set a first trigger for the pressure criterion and a second one for the relative humidity, and then you would check for the simultaneous occurence of the two triggers. More specifically,
.TP 5
.B GT:p:700:1(TRIGGER) & GT:RH:80:2(TRIGGER)
this will define the triggers for the two events. Note that both events might be fulfilled, in which case both triggers are set. The value of the trigger is: 1 if only the first criterion is fulfilled (binary 01); 2 if only the second is fulfilled (binary 10) and 3 if both are fulfilled (binary 11).
.TP 5
.B ALL:TRIGGER:1,2:ALL(ANY)
this will select all trajectories for which both triggers 1 and 2 are set - they can be set at any time of all the trajectory times; if, for instance, you would like to test whether the two triggers are set at the two times 6 and 12, the command would be
.B ALL:TRIGGER:1,2:6,12(ALL).
.TP 5
.B ALL:TRIGGER:1,2:ALL(ANY)
will only check whether one of the two triggers 1 and 2 is set
.TP 5
.B NONE:TRIGGER:1,2:ALL(ANY)
will check whether none of the two triggers 1 and 2 is set
.SH IMPLEMENTING COMPLEX CRITERIA
New special criteria can easily be implemented into the code - to this aim the following steps must be taken:
.TP 5
.B [1] <special.f>
in directory "${LAGRANTO}/select/" must be modified. Take the example "WCB" to see how the Fortran code must be changed.
.TP 5
.B [2] <install.sh select>
must be invoked to recompile the program "select". For successful compilation, the executable "select" will be listed.
.TP 0
Type <select -special> to get a list of all special commands and a detailed description.
.SH EXAMPLES
.TP 5
.B [1] select trainp traout 'GT:PV:2:LAST'
selects all trajectories with PV>2 PVU for the last time step. The input trajectories are given in trainp, the selected ones are written to traout. If the two filenames are the same, the input file is overwritten.
.TP 5
.B [2] select trainp traout 'IN:lat:-20,20:6,12'
selects all trajectories which are in the equatorial band at times 6 h and 12 h. The criterion must apply at both times.
.TP 5
.B [3] select trainp traout 'GT:lat:34:FIRST & GT:lon:50:FIRST'
selects the trajectories to the north of 34 N and to the east of 50 E at first
time. Several selection criteria can be combined with '&'.
.TP 5
.B [4] select trainp traout 'LT:p(MIN):300:ALL'
select all trajectories which have a minium pressure (p) less than 300 hPa over all times (ALL).
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/startf.0
0,0 → 1,195
.TH create_startf
.SH NAME
.B create_startf -
create starting files for Lagranto
.SH SYNOPSIS
.B create_startf
.I date
.I filename
.I specifier
[
.I optional arguments
]
.SH DESCRIPTION
Create starting files
for a Lagranto calculation. The staring positions are based on the P and S files for
.I date
and are as specified in a
.I specifier.
The starting coordinates (longitude, latitude, pressure [in hPa]) are written to the file
.I filename.
.SH PARAMETERS
.TP 15
.I date
date of input P and S file (e.g. 20100101_00). If the date is between two P and S files,
linear interpolation is used between the two times.
.TP 15
.I filename
output file with starting points (e.g. startf). Different formats are supported (see
.B reformat
for details)
.TP 15
.I specifier
detailed description of starting positions. The specifier has the following format:
.B
.I <horizontal>
@
.I <vertical>
@
.I
<unit>
@
.I <selection>.
The components of the specifier are described in greater detail in the following sections.
.SH HORIZONTAL
.TP 15
.B - file[filename]
read lat/lon from file "filename"; each line contains one lat/lon pair.
.TP 15
.B - line[lon1,lon2,lat1,lat2,n]
n points from (lon1,la1) to (lon2,lat2); the points are linearly interpolated in lat/lon space.
.TP 15
.B - box.eqd[lon1,lon2,lat1,lat2,ds]
lat/lon box bounded with south-western point (lon1,lat1) and north-eastern point (lon2,lat2); the equdistant points within the box have a horizontal distance ds (in [km]).
.TP 15
.B - box.grid[lon1,lon2,lat1,lat2,]
lat/lon box with south-western point (lon1,lat1) and north-eastern point (lon2,lat2 grid points; all grid points within this box are taken as staring points.
.TP 15
.B - point[lon,lat]
single lon/lat point.
.TP 15
.B - shift[lon,lat,dlon,dlat]
lon/at points and dlon/dlat shifhted ones, i.e. in total five points: central one and four shifted ones: (lon,lat), (lon+dlon,lat), (lon-dlon,lat), (lon,lat+dlat), (lon,lat-dlat).
.TP 15
.B - polygon.eqd[filename,ds]
equidistant within arbirtrary polygon (ds in [km]). The file with the polygon points has the following format: 1st line a lon/lat point within the polygon; further lines lon/lat points of the vertices (max 500) of the polygon.
.TP 15
.B - polygon.grid[filename]
grid points within arbirtrary polygon. The file with the polygon points has the following format: 1st line a lon/lat point within the polygon; further lines lon/lat points of the vertices (max 500) of the polygon.
.TP 15
.B - circle.eqd[lonc,latc,radius,ds]
circle with centre at (lonc,latc) and radius "radius" (in km); the equdistant points within the circle have a horizontal distance ds (in [km]).
.TP 15
.B - circle.grid[lonc,latc,radius]
circle with centre at (lonc,latc) and radius "radius" (in km); all rid points within the circle are selected.
.TP 15
.B - region.eqd[id,ds]
Read region specification from region file ("default regionf", to be changed with option "-regionf") and fill it equidistantly with starting points (ds in km). The region identification is "id", see below in section REGION FILE.
.TP 15
.B - region.grid[id]
Read region specification from region file ("default regionf", to be changed with option "-regionf") and fill it with starting points on the input grid. The region identification is "id", see below in section REGION FILE.
.SH VERTICAL
.TP 15
.B - file[filename]
read levels from file "filename"; each line in the file contains one level.
.TP 15
.B - level[lev]
a single level
.TP 15
.B - list[lev1,lev2,lev3,...]
a list of levels; if many levels are needed they are better passed to "create_startf" with the option "file[filename]".
.TP 15
.B - profile[lev1,lev2,n]
n equdistant levels between lev1 and lev2.
.TP 15
.B - grid[lev1,lev2]
all grid points within layer (lev1,lev2) are selected
.SH UNIT
.TP 15
.B - hPa
pressure (in hPa).
.TP 15
.B - hPa,agl
pressure (in hPa) above ground level.
.TP 15
.B - K
potential temperature (in K).
.TP 15
.B - PVU
potential vorticty (in PVU). Note that potential vorticity (PV) might not be unique as a vertical coordinate; if several levels have a given PV value, the highest one is chosen.
.TP 15
.B - INDEX
index of model level (1=surface).
.SH SELECTION
.TP 15
.B - criterion
Selection criteria based on meteorological fields applied to the starting position; The criteria follow the syntax of the program
.B select.
.TP 15
.B - nil
If no selection criteria should be invoked, the argument "nil" should be given.
.SH REGION FILE
Several starting regions can be defined for every case in a region file (default filename is "regionf"; to be changed with optional parameter "-regionf filename"). There are two possible formats for specifying a region (they require either a line with 5 or 9 entries):
.TP 5
.B "regnum lonw lone lats latn"
a regular latitude-longitude square: regnum=integer region number; lonw=westernmost longitude of starting region; lone=easternmost longitude; lats=southernmost latitude; latnNorthernmost latitude.
.TP 5
.B "regnum lon1 lat1 lon2 lat2 lon3 lat3 lon4 lat4"
an irregular latitude-longitude square: regnum=integer region number; lon{x},lat{x} = longitude and latitude of the x-th corner. Note that the 4 corners must be arranged counterclockwise. For a triangle the 4th corner can be specified identically to the 3rd.
.TP 5
.B Note: (1) if a line starts with '#' it is regarded as comment and not further considered; (2) each line in the region file must start with '"!
.TP 5
.B "101 -40. -24. 52. 60.":
region in the central Atlantic from 40 W to 24 W and 52 N to 60 N; the region identifier is 101.
.TP 5
.B "250 -30. 43. -24. 36. -18. 50.2 -35.2 50.2":
irregular square in the central Atlantic; the region identifier is 250.
.SH OPTIONAL
.br
.TP 15
.I -t tracefile
tracing file with variables for selection criteria (see
.B trace
for format of the file). If no file is specified, the default
"tracevars" is used. Further, if no selection criterion is invoked, no
tracing file is necessary.
.TP 15
.I -changet
flag whether the times of the P and S files should be changed or not before a calculation; the default is that the
times are not changed.
.TP 15
.I -noclean
flag whether parameter and criterion files should be kept; this is particularly helpfuld for debugging.
.TP 15
.I -regionf filename
change the region file from its default value "regionf" to a new file name: the syntax is "-regionf filename".
.TP 15
.I -timecheck
enforce a time check on the data files
.SH EXAMPLES
.TP 5
.B [1] create_startf 19891020_00 startf 'point(-10,50) @ list(450,500,550) @ hPa'
Starting points are (longitude, latitude, pressure in hPa): (-10,50,450); (-10,50,500); (-10,50,550). No selection criterion is applied; the positions are written to file "startf".
.TP 5
.B [2] create_startf 19891020_00 startf 'line(-10,-5,40,50,10) @ level(450) @ hPa,agl'
10 points are equidistantly specified between lon/lat point (-10,40) and (-5,50); all trajectories start at 450 hPa above ground level - the surface pressure is taken from the primary file P19891020_00. The positions are saved in "startf".
.TP 5
.B [3] create_startf 19891020_00 startf 'box.grid(-10,-5,40,50) @ list(300,320) @ K'
All grid points in the box with the south-eastern lon/lat point (-10,40) and the north-eastern one (-5,50) are taken - the horizontal grid spacing is specfified in the primary file P19891020_00. In the vertical, two isentropic levels are chosen: 300 K and 320 K. The potential temperature for the calculation is taken from the secondary file S19891020_00.
.TP 5
.B [4] create_startf 19891020_00 startf 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa'
A profile of 100 equidistant levels between 1000 hPa and 200 hPa; in the horizontal the central lon/lat point (-10,40) is taken and four horizontally displaced ones, the diplacement being 1 degree in zonal and meridional direction.
.TP 5
.B [5] create_startf 19891020_00 startf.1 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa'
As in the previous example [4], but the starting positions are saved as a trajectory file instead of a (lon,lat,p)-list.
.TP 5
.B [6] create_startf 19891020_00 startf.1 criterion
As in the previous example [5], but the criterion is saved on a file with filename "criterion".
.TP 5
.B [7] create_startf 19891020_00 startf 'polygon.grid(polygon) @ level(500) @ hPa
A polygon is specified in the file "polygon"; the different lines in the file are: -5. 45. / -10. 40. / 10. 40. / 10 50. / -10. 45. The first lon/lat point lies within the polygon, all other lon/lat points are the vertices of the polygon. All grid points within the polygon are taken as starting point, at level 500 hPa.
.TP 5
.B [8] create_startf 19891020_00 startf 'polygon.eqd(polygon,50) @ level(500) @ hPa
As in the previous example [7], except that the starting points are distributed equidistantly within the polygon. The horizontal distance between the starting points is 50 km in zonal and meridional direction.
.TP 5
.B [9] create_startf 19891020_00 startf 'shift(-10,40,1,1) @ profile(1000,200,100) @ hPa @ GT:TH:310'
As in example [4], but a selection criterion is additionally applied: only starting positions with potential temperature (TH) greater than (GT) 310 K are kept. Potential temperature must be available on the secondary file S19891020_00 and the file "tracevars" must have a line with "TH 1. 0 S". Further examples for selection criteria can be seen in
.B
select.
.TP 5
.B [10] create_startf 19891020_00 START.1 'region.eqd(3,10) @ level(500) @ hPa'
get equidistant starting points (10 km distance) in the region with identifier 3, as listed in the region file "regionf" (the default).
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/man/timeres.0
0,0 → 1,36
.TH timeres
.SH NAME
.B timeres - change the time resolution of a trajectory
.SH SYNOPSIS
.B timeres
.I inpfile
.I outfile
.I -[h|min] value
.I [-cubic|-linear]
.SH DESCRIPTION
Change the time resolution of an input trajectory file "inpfile" through interpolation and write a new trajectory file "outfile". The new time resolution "value" is given either in hours "-h" or in minutes "-min". The interpolation is performed on the trajectory file either in linear mode ("-linear") or in cubic spline mode ("-cubic"). The default is "-cubic".
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file
.TP 15
.I outfile
output trajectory file (can be the same as inpfile).
.TP 15
.I -h value
new time resolution in hours (e.g. "-h 1").
.TP 15
.I -min value
new time resolution in minutes (e.g. "-min 15").
.TP 15
.I -linear
linear interpolation between two trajectory times; note that this mode conserves the sign between two trajectory times - possibly of important for specific humidity, relative humidity,...
.TP 15
.I -linear
subic spline interpolation between two trajectory times; note that this mode conserves can change the sign between two trajectory times!
.SH EXAMPLES
.TP 5
.B [1] timeres trafile trafile -min 15 -linear
changes the time resolution to 15 minutes, using linear interpolation, and overwrites the old trajectory file.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011

/tags/1.0/docu/man/tracal.0
0,0 → 1,34
.TH tracal
.SH NAME
.B tracal - simple calculations with trajectory files
.SH SYNOPSIS
.B tracal
.I inpfile
.I outfile
.I expression
.SH DESCRIPTION
Simple calculation on the input trajectory file
.I inpfile
; the output is written to the output trajectory file
.I outfile
and the expression for the calculation is given in
.I expression.
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file
.TP 15
.I outfile
output trajectory file (can be the same as inpfile).
.TP 15
.I expression
arithmetic expression, e.g. 'DIFF=PS-p' to get difference between surface pressure (PS) and the pressure height of the trajectory (p). Note that the variable names must exactly match to the column names in the trajectory file.
The mathematical expression can contain previously defined variables, numbers (e.g., 1.5 or 1.5e-6), arithmetic operators (+, -, *, /, ^), and a number of mathematical functions (sin, cos, tan, sqrt, exp, log, ln, abs, ang, real, imag, conjg, complex). The expression can also use nested levels of parentheses for grouping. There are two predefined variables that are available to the user — the constant pi=3.14159265358979 and the imaginary unit i.
.SH EXAMPLES
.TP 5
.B [1] tracal inp out 'agl=z-zb'
caculates the difference between air parcel height (z) and surface height (zb). The result is saved in an new column (agl).
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (August 2012); the evaluation of the arithmetic expression is based on the string manipulation routines by 'Dr. George Benthien' (http://gbenthien.net/index.html).

/tags/1.0/docu/man/trace.0
0,0 → 1,193
.TH trace
.SH NAME
.B trace - trace meteorological fields along trajectories
.SH SYNOPSIS
.B trace
.I inpfile
.I outfile
[
.I optional arguments
]
.SH DESCRIPTION
Trace meteorological fields along the trajectories given in the input file
.I inpfile
and write a new trajectory file
.I outfile
. The meteorological fields to trace are listed in a
.I
tracing file
(default: tracevars). Partly they can be computed "online" (see ONLINE CALCULATIONS below), normally they are availbale on the primary and secondary P and S files.
.SH PARAMETERS
.TP 15
.I inpfile
input trajectory file; the appendix determines the format (see
.B reformat
for details).
.TP 15
.I outfile
output trajectory file; the appendix determines the format (see
.B reformat
for details).
.SH TRACING FILE
Normally the meteorological fields for tracing are listed in a file with name
.B "tracevars".
The name of the tracing file can be changed with the optional argument "-v" (see below). The format of the tracing file is as follows:
.br
.TP 5
Format
.I field[:shift]
.I scale
.I computation
.I prefix
.TP 5
Shifts (optional)
.B - field:+100km[lat]
- get field at trajectory position + 100 km shifted to north. A shift to south is obtained with field:-100km[lat].
.br
.B - field:+100km[lon]
- get field at trajectory position + 100 km shifted to east. A shift to west is obtained with field:-100km[lon].
.br
.B - field:+2[dlat]
- get field at trajectory position + 2 grid spacings dlat shifted to north. A shift to south is obtained with field:-2[dlat].
.br
.B - field:+2[dlon]
- get field at trajectory position + 2 grid spacings dlon shifted to east. A shift to west is obtained with field:-2[dlon].
.br
.B - field:+50hPa
- get field at trajectory position + 50 hPa shifted in vertical. A shift to lower pressures is obtained with field:-50hPa.
.br
.B - field:+1dp
- get field at trajectory position + 1 grid spacing DP shifted in vertical. A shift to lower pressures is obtained with field:-1dp. Note that DP is not fixed but varies with height.
.br
.B - field:+6h
- get field at trajectory position, but 6 h in the future. Shifts to the past are poeeible with field:-6h. In addition to hours (h), the time shift can be specified in minutes (min).
.TP 5
Examples
.B - TH 1. 0 S :
trace potential temperature (TH), scale it with 1 (no scaling); it is available on the S file (no computation is needed: 0).
.br
.B - Q 1000. 0 P :
trace specific humidity (Q), scale it with 1000 to have g/kg; it is available on the P file (no computation is needed: 0).
.br
.B - RH 1. 1 * :
trace relative humidity (RH), no scaling is needed (1.); relative humidity is not available on either P or S file and must be computed (1).
.br
.B - TH:100hPa 1. 0 S :
As in the first example, but now the potential temperature is taken 100 hPa below the air parcel position.
.SH OPTIONAL ARGUMENTS
.TP 15
.TP 15
.I -i hours
time increments (in hours) for input P and S files. If not explicitely specified, this is determined from the P and S files i
n the current directory.
.TP 15
.I -v varfile
Change the name of the tracing file from its default value "tracevars" to "varfile".
.TP 15
.I -f field scale
Trace field (with scaling scale) along the trajectories; the computation flag and the prefix for the data file is automatically set. This options allows the quick tracing of a field, without specifying a tracing file.
.TP 15
.I -changet
flag whether the times of the P and S files should be changed or not before a calculation; the default is that the
times are
.B not
changed.
.TP 15
.I -noclean
flag whether parameter and criterion files should be kept; this is particularly helpful for debugging.
.TP 15
.I -timecheck
enforce a time check for the data file
.SH SPECIAL INTERPOLATION MODES
.TP 15
.I -nearest
Do no interpolation between grid points; just take the nearest neighbor! This option is useful, if a discrete input field is given (e.g. labels), where interpolated values are meaningless.
.TP 15
.I -circle_avg radius
calculate area-weighted average over all grid points within a circle of the specified radius [km]. e.g. -circle_avg 200; note that the tracing of fields within a circle is quite slow.
.TP 15
.I -circle_max radius
calculate maximum within a circle of a radius [km]. e.g. -circle_max 200
.TP 15
.I -circle_min radius
calculate minimum within a circle of a radius [km]. e.g. -circle_min 200
.TP 15
.I -clustering
special mode to trace strat/trop label; the labels are attributed according to the program (tropopause), which clusters the atmosphere into five distinct classes according to the definition of the tropopause: PV (2 PVU) and potential temperature (380 K). The clustering mode is a refined version of the nearest mode, where all surrounding eight grid points vote for the final value.
.SH ONLINE CALCULATIONS
If the computation flag in the tracing file is set to 1, a meteorological field is calculated based upon the already traced fields and/or based on the fields on the primary and secondary P and S files. The following fields are implemented for online calculations:
.TP 5
.B - TH
potential temperature (in K).
.TP 5
.B - RHO
density (in kg/m^-3).
.TP 5
.B - RH
relative humidity (in %).
.TP 5
.B - THE
equivalent-potential temperature (in K).
.TP 5
.B - LHR
latent heating rate (K per input time step, typically K/6h).
.TP 5
.B - D[U,V,T,TH]DX
horizontal derivative d[U,V,T,TH]/dx in west-east direction along pressure surfaces - zonal distance in m. U=zonal wind component (m/s), V=meridional wind component (m/s), T=temperature (deg C or K), TH=potential temperature (K).
.TP 5
.B - D[U,V,T,TH]DY
horizontal derivative d[U,V,T,TH]/dy in south-north direction along pressure surfaces -meridional distance in m.
.TP 5
.B - D[U,V,T,TH]DP
vertical derivative d[U,V,T,TH]/dp - pressure p in Pa.
.TP 5
.B - NSQ
squared Brunt-Vaisala frequence (in m^-2).
.TP 5
.B - RELVORT
relative vorticity (in s^-1) - RELVORT = DVDX - DUDY.
.TP 5
.B - ABSVORT
absolute vorticity (in s^-1) - ABSVORT = DVDX - DUDY + F, F being the Coriolis parameter.
.TP 5
.B - DIV
horizontal divergence of the velocity field (in s^-1) - DIV = DUDX + DVDY.
.TP 5
.B - DEF
horizontal deformation of the velocity field (in s^-1) - DEF = SQRT( ( DVDX + DUDY )^2 + (DUDX-DVDY)^2 ).
.TP 5
.B - PV
Ertel potential vorticity (in PVU) - PV = g * ( ABSVORT * DTHDP + DUDP * DTHDY - DVDP * DTHDX ).
.TP 5
.B - RI
Richardson number - RI = NSQ / (DUDP^2 + DVDP^2 ).
.TP 5
.B - TI
tubulence indicator according to Ellrod & Knapp - TI = DEF * SQRT( DUDP^2 + DVDP^2 ) * ( RHO * G).
.TP 5
.B - DIR
wind direction relative to zonal flow: (U,V)=(1,1) -> 45 deg; (U,V)=(1,-1) -> -45 deg; (U,V)=(-1,-1) -> -135 deg; (U,V)=(-1,1) -> 135 deg. A westerly flow has 0 deg, a southerly flow 90 deg, and a northerly one -90 deg.
.TP 5
.B - DIST0
spherical distance (in km) from starting position.
.TP 5
.B - DIST
length of the trajectory (in km): integrated along great circle sections between the trajectory vertices.
.TP 5
.B - HEAD
heading of the trajectory: (DX,DY)=(1,1) -> 45 deg; (DX,DY)=(1,-1) -> -45 deg; (DX,DY)=(-1,-1) -> -135 deg; (DX,DY)=(-1,1) -> 135 deg. A path increment to east has heading of 0 deg; to the north 90 deg; to the south -90 deg; and to the west -180 deg.
.SH EXAMPLES
.TP 5
.B [1] trace TRAJECTORY.1 TRAJECTORY.1 -changet
Read the trajectory file TRAJECTORY.1, trace all fields in the file "tracevars" along the trajectories and overwrite the existing trajectory file. In preparation, all times on the P and S files are changed prior to the tracing.
.TP 5
.B [2] trace INPTRA.1 OUTTRA.1 -f PV 1.
Trace PV (with scaling factor 1.) along the trajectories in trajectory file "INPTRA.1" and write a new trajectory file "OUTTRA.1".
.TP 5
.B [3] trace INPTRA.1 OUTTRA.1 -f PV:-100HPA 1.
As in example [2], but the PV is taken at a position 100 hPa higher (lower pressure) than the air parcel's position.
.TP 5
.B [4] trace INPTRA.1 OUTTRA.1 -f DIST0 1.
Get the spherical distance (in km) of the air parcel from its starting position.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011).

/tags/1.0/docu/man/trainfo.0
0,0 → 1,58
.TH trainfo
.SH NAME
.B trainfo - write meta-information for a trajectory file
.SH SYNOPSIS
.B trainfo
.I trafile
[
.I option
].
.SH DESCRIPTION
Write meta-information for a trajectory file
.I trafile
to screen. If no option is given, all meta-information is written, otherwise the specific piece of information is passed with
.I option.
.SH PARAMETERS
.TP 5
.I trafile
name of the input trajectory file
.SH OPTIONAL ARGUMENTS
.TP 5
.B - dim
dimensions of the trajectory file: #tra, #ntimes, #ncolumns.
.TP 5
.B - ntra
number of trajectories.
.TP 5
.B - ntim
number of times.
.TP 5
.B - ncol
number of columns (including time, longitude, latitude, pressure).
.TP 5
.B - vars
list of field names (columns) on the trajectory file.
.TP 5
.B - refdate
reference date in format (YYYYMMDD_HHMM).
.TP 5
.B - times
list of times (relative to the referencec date). Times are given in format: HH.MM.
.TP 5
.B - startdate
starting date for the trajectory calculation (in format YYYYMMD_HHMM).
.TP 5
.B - enddate
end date for the trajectory calculation (in format YYYYMMD_HHMM).
.TP 5
.B - timerange
time range (in minutes) of the trajectories.
.TP 5
.B - list
list all trajectories.
.SH EXAMPLES
.TP 5
.B [1] trainfo file dim
Given a trajectory file with name "file", write the three dimensions of the file to screen. The dimensions are: number of trajectories, number of times and number of columns.
.SH AUTHOR
Written by Michael Sprenger and Heini Wernli (January 2011)

/tags/1.0/docu/presentation/presentation.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/pdf
Property changes:
Added: svn:mime-type
+application/pdf
\ No newline at end of property

/tags/1.0/docu/presentation/presentation.pptx
Cannot display: file marked as a binary type.
svn:mime-type = application/vnd.openxmlformats-officedocument.presentationml.presentation
Property changes:
Added: svn:mime-type
+application/vnd.openxmlformats-officedocument.presentationml.presentation
\ No newline at end of property

/tags/1.0/docu/reference/reference.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/pdf
Property changes:
Added: svn:mime-type
+application/pdf
\ No newline at end of property

/tags/1.0/docu/reference/title.tex
0,0 → 1,22
\documentclass[a4paper,10pt]{article}
\usepackage[utf8x]{inputenc}
\usepackage{graphicx}
\graphicspath{{/home/sprenger/lagranto/docu/tutorial/}}
\textwidth16cm
\textheight22.5cm
\oddsidemargin0.5cm
\evensidemargin0cm
\topmargin0.cm
\headsep0cm
\topskip-0.5cm
\title{Lagranto - Reference}
\author{Michael Sprenger and Heini Wernli}
\begin{document}
\maketitle
\end{document}

/tags/1.0/docu/tutorial/screen1.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/screen2.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/screen3.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/screen4.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/screen5.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/tutorial.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/pdf
Property changes:
Added: svn:mime-type
+application/pdf
\ No newline at end of property

/tags/1.0/docu/tutorial/tutorial.ps
Cannot display: file marked as a binary type.
svn:mime-type = application/postscript
Property changes:
Added: svn:mime-type
+application/postscript
\ No newline at end of property

/tags/1.0/docu/tutorial/tutorial.tex
0,0 → 1,832
\documentclass[a4paper,10pt]{article}
\usepackage[utf8x]{inputenc}
\usepackage{graphicx}
\graphicspath{{/home/sprenger/lagranto/docu/tutorial/}}
\textwidth16cm
\textheight22.5cm
\oddsidemargin0.5cm
\evensidemargin0cm
\topmargin0.cm
\headsep0cm
\topskip-0.5cm
\title{Lagranto - Tutorial}
\author{Michael Sprenger and Heini Wernli}
\begin{document}
\maketitle
\section{Definition of the Problem}
In this tutorial we consider a simple way how to find airstreams which transport air from the surface into the upper troposphere and lower stratosphere, i.e. the UTLS region. More specifically, we intend
\begin{itemize}
\item[1)] to initialize starting positions over the North Atlantic and Europe (80 W to 20 E, 40 N to 80 N) for 00 UTC, 20 October 1989. The starting positions are horizontally equidistant with 80 km horizontal spacing and are set 100 hPa above ground level.
\item[2)] to calculate trajectories 72 hours forward in time.
\item[3)] to select trajectories which ascend to levels above 400 hPa within 48 hours and are found at starting time below 700 hPa.
\item[4)] to trace several meteorological fields along the trajectories: potential vorticity (PV), potential temperature (TH), relative (RH) and specific humidity (Q).
\item[4] to select subsamples of trajectories: a) those reaching the stratosphere; b) those travelling at most 2000 km; ...
\item[5)] to show the densities of the trajectories on a geographical map.
\end{itemize}
\section{Meteorological Data}
The following dates and netCDF files are needed for a Lagranto calculation covering the time period from 00\,UTC 20 October 1989 to 00\,UTC 23 October 1989.
\begin{verbatim}
> datelist stdout -create 19891020_00 19891023_00
19891020_00
19891020_06
19891020_12
...
19891022_06
19891022_12
19891022_18
19891023_00
\end{verbatim}
\noindent
There are two different files involved, the P and the S files. Lagranto expects them to be in the running directory:
\begin{verbatim}
> ls -1
P19891020_00 P19891020_06 P19891020_12 P19891020_18
P19891021_00 P19891021_06 P19891021_12 P19891021_18
...
S19891020_00 S19891020_06 S19891020_12 S19891020_18
S19891021_00 S19891021_06 S19891021_12 S19891021_18
...
\end{verbatim}
\noindent
The meteorological fields on the primary P files are at least: zonal wind (U, in m/s); meridional wind (V, in m/s); vertical wind (OMEGA, in Pa/s);
surface pressure (PS, in hPa). Additional fields might be available on the P files, e.g. temperature (T), specific
humidity (Q),... Secondary fields can be saved in the S files, which must have the same grid structure as the P files.
In the example the following fields are saved on the S files: potential temperature (TH, in K); Ertel potential vorticity (PV, in pvu); relative humidity (in \%).
Furthermore, the surface pressure (PS) is also saved on the S files; it must be exactly identical to the one in the P files.\\
\noindent
If the P and S files are stored at another place, they might be linked with a simple Shell script (in csh), usimg the command {\em datelist}:
\begin{verbatim}
> foreach date ( `datelist stdout -create 19891020_00 19891023_00` )
> ln -s {SOURCE DIR}/P${date} {DEST DIR}/P${date}
> ln -s {SOURCE DIR}/S${date} {DEST DIR}/S${date}
> end
\end{verbatim}
Note that the command {\em datelist} offers several options how to work with date list - creating, stepping through, comparing.
\section{Starting Positions}
In a first step the starting positions must be specified. To this aim a file {\em regionf} must be created with the definition of the region. The file is in the same directory as the meteorological data (section 1):
\begin{verbatim}
> more regionf
"1 -80 20 40 80"
\end{verbatim}
\noindent
The first number specifies a region ID (here 1) and the other values are: west boundary (80 W), east boundary (20 E), southern boundary (20 N) and northern boundary (80 N). The starting positions are then created with
\begin{verbatim}
> create_startf 19891020_00 startf.2 'region.eqd(1,80) ...
... @ level(100) @ hPa,agl' -changet
\end{verbatim}
\noindent
The starting positions are written to {\em startf.2}, i.e. in format 2, and cover the region 1 specified in {\em regionf}. The horizontal start points are equidistantly distributed with 80 km spacing, and they are all at 100 hPa above ground. All points refer to the starting date 00 UTC, 20 October 1989.
In total, 3750 starting positions are written to {\em startf.2}. The first few lines of the file look as follows:
\begin{verbatim}
> head -10 startf.2
Reference date 19891020_0000 / Time range 0 min
time lon lat p level
---------------------------------------
0.00 -79.61 40.45 862 100.000
0.00 -78.66 40.45 860 100.000
0.00 -77.71 40.45 873 100.000
0.00 -76.76 40.45 886 100.000
0.00 -75.82 40.45 893 100.000
\end{verbatim}
\noindent
The different columns are: time, longitude, latitude, pressure (in hPa) and level (in hPa,agl). Note that the 'same' starting file could have been created without a region file. In this case, the command would have been:
\begin{verbatim}
> create_startf 19891020_00 startf.2 'box.eqd(-80,20,40,80,80) ...
... @ level(100) @ hPa,agl' -changet
\end{verbatim}
\noindent
However, note that the starting positions are not exactly the same as with the previous command: it is only guaranteed that the starting points are equidistantly distributed within the region.
\section{Trajectory Calculation}
In a next step, the trajectories are calculated 72 h forward in time, with starting date 00 UTC, 20 October 1989. The command is:
\begin{verbatim}
> caltra 19891020_00 19891023_00 startf.2 traj.4 -j
\end{verbatim}
\noindent
The taring positions are taken from{\em startf.2} and the output is written to {\em traj.4}. Furthermore, the jumping flag {\em -j} is set, i.e. if trajectories run into the ground they are lifted a little and allowed to move on.\\
\noindent
Note that the output file {\em traj.4} is not in ASCII format. To look at the file, use the command {\em trainfo}, for instance:
\begin{verbatim}
> trainfo traj.4 vars
time lon lat p
> trainfo traj.4 dim
3750 13 4
> trainfo trai.4 startdate
19891020_0000
\end{verbatim}
\noindent
It is also possible to convert the trajectory file into ASCII format with the command {\em reformat}:
\begin{verbatim}
> reformat traj.4 traj.1
> more traj.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p
-----------------------------
0.00 -79.61 40.45 862
6.00 -80.57 43.23 791
12.00 -82.23 45.89 782
18.00 -84.94 47.07 744
\end{verbatim}
\noindent
The command {\em trafinfo} cna also be used to look at the trajectory tables, i.e. without a conversion to ASCII format. To this aim, use
\begin{verbatim}
> trainfo traj.4 list
\end{verbatim}
\noindent
Whereas the ASCII format is most convenient for visual inspection, it is the least compact format. In particular, if the output of {\em caltra} should be further processed, e.g. with {\em trace} or {\em select}, the binary formats should be used (see documentation for {\em reformat}).
\section{Pre-Selection of Trajectories}
Quite often, the position of the air parcels is sufficient to select trajectories. It is then most efficient to pre-select these trajectories and do the tracing of additional fields along the trajectories only on the pre-selected ones. In the example, airstreams should be identified which ascend from below 700 hPa at initial time to levels above 300 hPa. The ascent has to take place within 48 h. This selection can be achieved with the command:
\begin{verbatim}
> select traj.4 wcb.1 'GT:p:700:FIRST & LT:p(MIN):400:0 to 48'
\end{verbatim}
\noindent
The first criterion selects all trajectories for which the pressure (p) at the initial time (FIRST) is greater than (GT) 700 hPa. This criterison is logically AND-combined with the second criteron: consider all times between 0 and 48 h and take the minimum pressure, i.e. p(MIN), over this time interval; if the minium pressure is less than (LT) 400 hPa, the trajectory is selected. A sample trajectory looks like:
\begin{verbatim}
> trainfo wcb.1 list
Reference date 19891020_0000 / Time range 4320 min
time lon lat p
-----------------------------
0.00 -72.98 40.45 918
6.00 -76.45 43.14 879
12.00 -78.53 46.69 808
18.00 -80.08 48.70 770
24.00 -84.49 48.71 563
30.00 -87.89 43.32 377
36.00 -80.69 37.24 396
42.00 -73.05 39.00 477
48.00 -67.62 47.21 488
54.00 -63.53 54.61 455
60.00 -53.79 58.53 447
66.00 -38.79 59.08 452
72.00 -27.72 55.51 493
\end{verbatim}
\noindent
In total, 99 trajectories are selected. Further Lagrangian selection criteria might be reasonable. For instance, it could be of interest whether the air parcels are far away from their initial position after 48 h:
\begin{verbatim}
> select traj.4 wcb.1 'GT:p:700:FIRST & LT:p(MIN):400:0 to 48 & GT:DIST0:5000:48'
\end{verbatim}
\noindent
The last criterion test whether the spherical distance from the initial position exceeds 5000 km at 48 h (only met by 4 trajectories). Note that the field {\em DIST0} is not available on the trajectory file {\em traj.4}, but is implicitely calculated. \\
\noindent
Similarly, it can be tested whether a trajectory passes through a target region (e.g. 20E-30E,50N-60N). Such a region might be defined in the region file {\em regionf}:
\begin{verbatim}
> more regionf
# Starting positions
"1 -80 20 40 80"
# Target region
"2 20 30 50 60"
\end{verbatim}
\noindent
The call to {\em select} now looks as follows:
\begin{verbatim}
> select traj.4 wcb.1 'GT:p:700:FIRST & LT:p(MIN):400:0 to 48 & ...
... TRUE:INREGION:2:42 to 54(ANY)'
\end{verbatim}
\noindent
The last criterion is interpreted in the following way: consider the times from 42 h to 48 h (42 to 54) and check whether a trajectory is at any of these times (ANY) in the traget region 2, as specified in {\em regionf}. A sample trajectory is given below:
\begin{verbatim}
> more wcb.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p
-----------------------------
0.00 -44.56 40.45 914
6.00 -41.22 38.95 885
12.00 -37.50 37.59 849
18.00 -33.54 36.76 823
24.00 -29.45 36.45 770
30.00 -24.56 37.44 622
36.00 -18.89 41.17 429
42.00 -10.48 49.48 349
48.00 8.75 57.02 355
54.00 28.74 56.97 354
60.00 37.14 53.71 320
66.00 38.99 49.75 334
72.00 37.57 45.94 349
\end{verbatim}
\section{Tracing Meteorological Fields}
Meteorological fields can be traced along the trajectories with the command {\em trace}. Most often, a list of fields to trace will be listed in a file {\em tracevars}:
\begin{verbatim}
> more tracevars
PS 1. 0 P
Q 1000. 0 P
TH 1. 0 S
RH 1. 1 *
\end{verbatim}
\noindent
The following fields are to be traced: surface pressure (PS), specific humidity (Q), potential temperature (TH) and relative humidity (RH). PS and Q are available on the P files and need not to be calculated; Q will be scaled by a factor 1000 to convert from Kg/kg to g/kg. TH is found on the S file and need not to be calculated. Finally, RH is found neither on the P nor on the S file and must becomputed - the flag 1 in the third column.\\
\noindent
With the {\em tracevars} file ready, the tracing is started with:
\begin{verbatim}
> trace wcb.1 wcb.1
\end{verbatim}
\noindent
Note that the input and output file are allowed to have the same name. The following table shows the first few lines of the new trajectory file:
\begin{verbatim}
> more wcb.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p PS Q TH RH
---------------------------------------------------------------------
0.00 -44.56 40.45 914 1014.093 9.664 294.921 86.667
6.00 -41.22 38.95 885 1012.965 8.380 296.549 77.992
12.00 -37.50 37.59 849 1014.056 8.565 299.122 81.321
18.00 -33.54 36.76 823 1012.074 8.720 300.798 85.407
24.00 -29.45 36.45 770 1012.254 7.666 303.487 85.262
\end{verbatim}
\noindent
If it is later found that additional fields should be traced, this can be done with a new {\em tracevars} file or for a single field with (the second number being the scaling factor):
\begin{verbatim}
> trace wcb.1 wcb.1 -f PV 1.
\end{verbatim}
\noindent
Note that several fields are allowed for online computation, i.e. with the computation flag set in {\em tracevars}. This is convenient for interactive mode and for few trajectories. However, if tracing is needed for many trajectories, a pre-calculation and saving on the S files is much more efficient! A list of fields for online computation is found in the reference guide for {\em trace}. \\
\noindent
It is also possible to trace the surrounding of a trajectory position, i.e. to get for instance not the temperature at the air parcel's position, but at 50 hPa above or below it. This is done with:
\begin{verbatim}
> trace wcb.1 wcb.1 -f T:-50HPA 1.
> trace wcb.1 wcb.1 -f T:+50HPA 1.
\end{verbatim}
\noindent
Finally, if it is decided that a field is no longer needed in the trajectory file, or if it has to be corrected, it is possible to remove columns from the trajectory file. This can be achieved with {\em extract} - for instance if only PS, TH and RH should be kept:
\begin{verbatim}
> extract wcb.1 wcb.1 -var PS TH RH
\end{verbatim}
\noindent
Note that {\em extract} can also be used to extract different times or starting positions (see the reference documentation).
\section{Final Selection of Trajectories}
In this section the selection of trajectories should be refined, i.e. it is not only based on positional information but also on further meteorological parameters. We look at several questions:\\
\begin{itemize}
\item[a)] Is there a trajectory which reaches saturation ($RH>99$\%)? The trajectories should be saved in a new trajectory file.
\begin{verbatim}
> select wcb.1 sat.1 'GT:RH:99:0 to 72(ANY)'
> more sat.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p PS Q TH RH PV
---------------------------------------------------------------------------------
0.00 -72.98 40.45 918 1018.161 9.503 292.020 100.722 0.920
6.00 -76.45 43.14 879 986.319 8.723 294.933 92.837 1.101
12.00 -78.53 46.69 808 972.550 7.621 297.875 97.737 0.794
18.00 -80.08 48.70 770 973.957 6.147 297.914 97.912 1.078
24.00 -84.49 48.71 563 962.279 2.327 307.548 87.923 1.034
30.00 -87.89 43.32 377 977.415 0.319 314.210 65.759 0.108
36.00 -80.69 37.24 396 939.606 0.303 312.705 52.845 0.323
42.00 -73.05 39.00 477 1013.693 0.298 314.614 16.248 0.309
48.00 -67.62 47.21 488 970.025 0.442 312.975 23.890 0.463
54.00 -63.53 54.61 455 950.011 0.386 313.047 30.182 0.479
60.00 -53.79 58.53 447 1007.039 0.392 311.951 36.578 0.487
66.00 -38.79 59.08 452 1006.532 0.319 311.316 29.286 0.443
72.00 -27.72 55.51 493 1009.871 0.279 311.428 15.950 0.513
\end{verbatim}
\item[b)] Get a list of all trajectories which pass through a circle around 20\,W/40\,N and radius 500\,km.
\begin{verbatim}
> select wcb.1 indlist 'TRUE:INCIRCLE:-20,40,500:ALL(ANY)' -index
> more indlist
4
5
6
11
12
13
14
19
20
21
22
47
\end{verbatim}
Hence, the trajectories 4,5,... pass through the circle. The trajectories themselves can be extracted in a second step with
\begin{verbatim}
> extract wcb.1 pass.1 -index indlist
\end{verbatim}
where now the selected trajectories are written to the trajectory file {\em pass.1}.
\item[c)] Select all trajectories which are in the stratosphere after 48 h. The dynamical tropopause is defined as the 2-PVU isosurface?
\begin{verbatim}
> select wcb.1 out 'GT:PV:2:48 to 72(ALL) & LT:P:500:48 to 72(ALL)'
\end{verbatim}
The second criterion guarantees that the air parcel is at a height above 500 hPa; indeed, low-level high-PV regions might mimick a stratosphere, although they are of diabatic origin.
\item[d)] Select all trajectories which are within 2000 km distance of their starting position after 72 h.
\begin{verbatim}
> select wcb.1 sel.1 'LT:DIST0:2000:LAST'
\end{verbatim}
Note that the fields {\em DIST0} needs not to be available on the trajectory file - it is calculated during the selection. {\em DIST0} refers to the spherical distance (in km) from the strting position. If the path length (in km) is needed, {\em DIST} can be used instead.
\item[e)] How many trajectories ascend more than 550 hPa between 12 h and 54 h? We are only interested in the number of selected trajectories.
\begin{verbatim}
> select wcb.1 count 'GT:P(DIFF):550:12,54' -count
> more count
3
\end{verbatim}
\item[f)] We would like to select all trajectories which reach potential vorticity (PV) greather than 2 PVU at levels above 500 hPa. In a first attempt, this might be accomplished with the criterion
\begin{verbatim}
> select wcb.1 wcb.1 'GT:PV:2:ALL(ANY) & LT:p:500:ALL(ANY)'
\end{verbatim}
But note that this is not exactly what we want - the first criterion might be fulfilled at a time 48 h, for instance, whereas the second criterion is fulfilled at another time, say 72 h. Hence they are not both fulfilled at the same time! A way around this problem is possible if a TRIGGER column is used to mark the two events. The original trajectory file looks as follows:
\begin{verbatim}
> more wcb.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p PS RH PV
------------------------------------------------------------
0.00 -19.56 46.94 905 1005.242 83.514 0.291
6.00 -14.72 48.17 892 999.182 88.325 0.242
12.00 -10.58 50.53 862 993.145 97.718 0.293
18.00 -7.22 53.02 792 972.076 99.216 0.738
24.00 -3.71 55.89 724 956.135 93.218 1.076
30.00 -0.19 58.87 629 971.334 70.088 1.076
36.00 1.46 61.62 452 966.406 66.056 0.558
42.00 0.01 62.49 328 977.209 65.319 1.754
48.00 -1.54 63.41 313 983.930 56.822 2.727
54.00 -3.59 64.77 322 984.627 58.328 1.874
60.00 -9.91 66.07 323 988.185 57.894 2.052
66.00 -20.91 66.02 316 976.560 57.989 2.565
72.00 -28.89 66.19 319 1007.175 54.477 2.693
\end{verbatim}
Then we mark the two events with a TRIGGER:
\begin{verbatim}
> select wcb.1 wcb.1 'GT:PV:2:1(TRIGGER) & LT:p:500:2(TRIGGER)' -trigger
\end{verbatim}
The first criterion (PV) gets the trigger 1 (in binary system 01), the second one (pressure) get the trigger 2 (in binary system 10). If both criteria are fulfilled, the trigger column becomes 3, which corresponds in the binary system to 11 - i.e. each flag corresponds to a bit in the trigger value. With the option '-trigger' the trigger column is written to the output trajectory file:
\begin{verbatim}
> more wcb.1
Reference date 19891020_0000 / Time range 4320 min
time lon lat p PS RH PV TRIGGER
-------------------------------------------------------------------------
0.00 -19.56 46.94 905 1005.242 83.514 0.291 0.000
6.00 -14.72 48.17 892 999.182 88.325 0.242 0.000
12.00 -10.58 50.53 862 993.145 97.718 0.293 0.000
18.00 -7.22 53.02 792 972.076 99.216 0.738 0.000
24.00 -3.71 55.89 724 956.135 93.218 1.076 0.000
30.00 -0.19 58.87 629 971.334 70.088 1.076 0.000
36.00 1.46 61.62 452 966.406 66.056 0.558 2.000
42.00 0.01 62.49 328 977.200 65.319 1.754 2.000
48.00 -1.54 63.41 313 983.930 56.822 2.727 3.000
54.00 -3.59 64.77 322 984.627 58.328 1.874 2.000
60.00 -9.91 66.07 323 988.185 57.894 2.052 3.000
66.00 -20.91 66.02 316 976.560 57.989 2.565 3.000
72.00 -28.89 66.19 319 1007.175 54.477 2.693 3.000
\end{verbatim}
Now the selection can be achieved by refering to the TRIGGER column:
\begin{verbatim}
> select wcb.1 wcb.1 'ALL:TRIGGER:1,2:ALL(ANY)'
\end{verbatim}
This selection means that the trigger values 1 and 2 must be set - the operator ALL (first term) guaranteeing that all selected triggers are set. The time specification ALL(ANY) is as before, i.e. the check is performed for all times and he criterion must be fulfilled at any of these times.\\
\item[g)] Select all trajectories which pass at time 60 h over Switzerland! The coordinates of the Swiss boundary are listed in a file {\em borders.dat}:
\begin{verbatim}
> more borders.dat
8.55 47.45
7.942863 46.002075
7.949024 46.001195
7.956945 46.000022
7.984226 46.000022
7.989800 46.001489
8.000068 46.007356
8.011508 46.018503
...
\end{verbatim}
The first line is a point (longitude, latitude) within Switzerland (Zurich), the other lines define the boundary of Switzerland (as 1373 points). With this polygon file, the selection command becomes
\begin{verbatim}
> select wcb.1 out.1 'TRUE:INPOLYGON:borders.dat:60'
\end{verbatim}
Note that in a criterion only one polygon can be specified.
\item[g)] New criteria can easily be implemented into the Fortran code; to this aim the file {\em special.f} in directory {\em select} must be edited. The following example shows the implementation of an identification for warm conveyor belts (WCB). The calling sequence for the criterion is {\em SPECIAL:WCB:ascent,first,last}, the air stream must ascend at least {\em ascent} hPa between time {\em first} and time {\em last}. The corresponding Fortran looks as follows:
\begin{small}
\begin{verbatim}
> more select/special.f
SUBROUTINE special (flag,cmd,tra,ntim,ncol,
> vars,times,param,nparam)
c ***************************************************************************
c * *
c * OUTPUT: flag -> 1 if trajectory is selected, 0 if not *
c * *
c * INPUT: cmd <- command string (e.g. WCB) *
c * tra(ntim,ncol) <- single trajectory: indices time,column *
c * ntim <- number of times *
c * ncol <- number of columns (including time,lon,lat,p) *
c * vars(ncol) <- names of columns *
c * times(ntim) <- List of times
c * param(nparam) <- parameter values *
c * nparam <- number of parameters *
c * *
c ***************************************************************************
implicit none
c ---------------------------------------------------------------------------
c Declaration of subroutine parameters
c ---------------------------------------------------------------------------
integer flag ! Boolean flag whether trajectory is selected
character*80 cmd ! Command string
integer ntim,ncol ! Dimension of single trajectory
real tra(ntim,ncol) ! Single trajectory
character*80 vars(ncol) ! Name of columns
real times(ntim) ! List of times
integer nparam ! # parameters
real param(nparam) ! List of parameters
c ---------------------------------------------------------------------------
c Declaration of local variables
c ---------------------------------------------------------------------------
integer i
integer ip,i0,i1
c -------------------------------------------------------------------------- %)
c SPECIAL:WCB:ascent,first,last %)
c : Detect Warm Conveyor Belts (WCB); the air stream must ascend at least %)
c : <ascent=param(1)> hPa between the two times <first=param(2)> and %)
c : <last=param(3)>. Note, the lowest pressure is allowed to occur at any %)
c : time between <first> and <last>. %)
c --------------------------------------------------------------------------- %)
if ( cmd.eq.'WCB' ) then
c Reset the flag for selection
flag = 0
c Pressure is in the 4th column
ip = 4
c Get indices for times <first> and <last>
i0 = 0
i1 = 0
do i=1,ntim
if ( param(2).eq.times(i) ) i0 = i
if ( param(3).eq.times(i) ) i1 = i
enddo
if ( (i0.eq.0).or.(i1.eq.0) ) then
print*,' ERROR: invalid times in SPECIAL:WCB... Stop'
stop
endif
c Check for ascent
do i=i0+1,i1
if ( ( tra(1,ip)-tra(i,ip) ) .gt. param(1) ) flag = 1
enddo
endif
c ---------------------------------------------------------------------------
end
\end{verbatim}
\end{small}
\end{itemize}
\section{Trajectory Densities}
Single trajectories can be visualised e.g. with Matlab or wit NCL (see template scripts in the Lagranto folder). If many trajectories should be visualised instead, it is much more convenient to show trajectory densities. The easiiest way to get trajectory densities is:
\begin{verbatim}
> density wcb.1 densisty
> ncview density
\end{verbatim}
This will project the trajectories in the trajectory file {\em wcb.1} onto a global longitude/latitude grid with 1 degree horizontal resolution. A filter radius of 100 km will be used
\includegraphics[width=0.9\textwidth]{screen1.ps}
\noindent
The CF-netCDF file contains several fields: a) the number of trajectory points associated to each grid point (COUNT); b) the residence time of the trajectories (in hours) associated to each grid point - the residence time being the time a trajectory stays at a certain grid cell (RESIDENCE); c) the area (im $km^2$) associated with each grid cell. The area allows to change the unit of the gridded trajectory from counts per grid point to counts per $km^2$.\\
\noindent
Often the trajectories do not spread over the whole globe; then the subdomain can be specified with
\begin{verbatim}
> density traj.1 density -latlon 300 150 -100 10 0.5 0.5 -create
\end{verbatim}
where the new grid has 300x150 grid points in zonal and meridional direction with south-eastern corner at 100\,W/10\,S and resolution of 0.5 degree in zonal and 0.5 degree in meridional direction. The flag {\em create} forces the netCDF file to be created anew, even if it already exists.
\includegraphics[width=0.9\textwidth]{screen2.ps}
\noindent
It is also possible to re-parameterise the trajectories before they are gridded. For instance, the following command interpolates the positions to a 1-h time interval and then performs the grissing. This results in a smoother density plot:
\begin{verbatim}
> density traj.1 density -latlon 300 150 -100 10 0.5 0.5 -create -interp 1 h
\end{verbatim}
\includegraphics[width=0.9\textwidth]{screen3.ps}
\noindent
In addition to a gridding of the complete trajectories, the single trajectory times can be gridded.
\begin{verbatim}
> density traj.1 density -create -time 0.00 -create
> density traj.1 density -create -time 6.00
> density traj.1 density -create -time 12.00
> density traj.1 density -create -time 18.00
> density traj.1 density -create -time 24.00
\end{verbatim}
\noindent
In the previous figures, the density of the trajectories was determined - i.e. the number of trajectories associated with a grid point or the residence associated with a grid cell was determined. In addition to this most basic information, it is also possible to perform a gridding of any trajectory field. For instance, the trajectory file contains
\begin{verbatim}
Reference date 19891020_0000 / Time range 4320 min
time lon lat p
-----------------------------
0.00 -79.61 40.45 862
6.00 -80.57 43.23 791
12.00 -82.23 45.89 782
18.00 -84.94 47.07 744
\end{verbatim}
\noindent
and we would like to know at what height the trajectories typically (in the mean) are at a specific grid point. Then we would grid the pressure ``p'' instead of the position:
\begin{verbatim}
> density traj.1 density -create -latlon 300 150 -100 10 0.5 0.5 -field p -time 0.00
> density traj.1 density -field p -time 24.00
> density traj.1 density -field p -time 48.00
\end{verbatim}
\noindent
The following figures show the gridded pressure at time 0.00 and 24.00 h; note that the trajectories were initialised 100 hPa above ground.
\noindent
\begin{center}
\includegraphics[width=0.8\textwidth]{screen4.ps}
\\
\includegraphics[width=0.8\textwidth]{screen5.ps}
\end{center}
\section{Interface Script}
\subsection{Start from local directory}
In addition to the programs {\em create\_startf}, {\em caltra}, {\em trace}, {\em select}, Lagranto offers a ``master'' script which combines the call to the individual programs into one single call. For instance,
\begin{verbatim}
> lagranto local 19891020_00 19891024_18 startf nil -changet
\end{verbatim}
will start a Lagranto run starting from 00,UTC 20 Octiober 2010 to 18,UTC 24 Octiober 2010, based upon the starting positions in the file {\em startf}. No selection of trajectories is applied, as specified with the flag {\em nil}, and the times on the netCDF P and S files are set relative to the starting date prior to the Lagranto run. Finally, {\em local} means that all input files are expected in the directory where Lagranto was called.\\
\noindent
The output for the above Lagranto call is saved in a newly created directory, which is located in the calling directory:
\begin{verbatim}
> ls -l ntr_19891020_00_f114_local_startf_nil/
-rw-r--r-- 1 michaesp wheel 5328945 2011-03-21 14:03 lsl_19891020_00
-rw-r--r-- 1 michaesp wheel 68195 2011-03-21 14:03 runscript.logfile
-rwxr--r-- 1 michaesp wheel 1025 2011-03-21 14:02 runscript.sh*
\end{verbatim}
The three different files are:
\begin{itemize}
\item[a)] {\bf lsl\_19891020\_00}: the output trajectory file -the file name starts with {\em lsl} and contains the starting date of the Lagranto run:
\begin{verbatim}
> more lsl_19891020_00
Reference date 19891020_0000 / Time range 6840 min
time lon lat p PS Q TH RH
---------------------------------------------------------------------
0.00 -79.61 40.45 862 961.659 6.434 290.838 97.722
6.00 -80.57 43.23 791 980.984 5.334 293.824 98.773
...
\end{verbatim}
Note that additional fields have been traced along the trajectories, as specified in the tracing file {\em tracevars}:
\begin{verbatim}
> more tracevars
PS 1. 0 P
Q 1000. 0 P
TH 1. 0 S
RH 1. 1 *
\end{verbatim}
\item[b)] {\bf runscript.logfile}: a log file with all status and error information of the Lagranto run. If the flag {\em -log} is set in a Lagranto call, the log will be written to screen.
\item[c)] {\bf runscript.sh}: the calling script for the programs {\em create\_startf}, {\em caltra}, {\em trace} and {\em select}. The basic idea of {\em lagranto} is to create the output directory, to prepare all netCDF and other files in this output directory and to create a Shell script with name {\em runscript.sh}. If all these preparations were successfull, Lagranto will change into the output directory and launch {\em runscript.sh}. The {\em runscript.sh} for the previous Lagranto call looks as follows:
\begin{small}
\begin{verbatim}
#!/bin/csh
#
#----- Calling command
#
# lagranto local 19891020_00 19891024_18 startf nil -changet -log
#
#----- Output file
#
# lsl_19891020_00
#
#------ Abort if no startf is available
#
if ( ! -f startf ) then
echo " ERROR: no start file available .... Stop"
exit 1
endif
#
#------ Remove existing trajectory files
#
if ( -f lsl_19891020_00.4 ) then
\rm -f lsl_19891020_00.4
endif
if ( -f lsl_19891020_00 ) then
\rm -f lsl_19891020_00
endif
#
#------ Run <caltra>
#
/home/sprenger/lagranto//bin/caltra.sh 19891020_00 19891024_18 startf lsl_19891020_00.4
#
#------ Abort if caltra was not successful
#
if ( ! -f lsl_19891020_00.4 ) then
echo " ERROR: caltra failed .... Stop"
exit 1
endif
#
#------ Run <trace>
#
/home/sprenger/lagranto//bin/trace.sh lsl_19891020_00.4 lsl_19891020_00 -v tracevars
#
#------ Abort if trace was not successful
#
if ( ! -f lsl_19891020_00 ) then
echo " ERROR: trace failed .... Stop"
exit 1
endif
\end{verbatim}
\end{small}
\end{itemize}
\noindent
Note that you are free to change to the output directory and manually launch {\em runscript.sh}, possibly after having modified it to your needs. This way of working is uspported by the optional flag {\em -prep} which will only prepare all files and then changes to the output directory:
\begin{verbatim}
> lagranto local 19891020_00 19891024_18 startf nil -changet -prep
\end{verbatim}
At the end of this call you will be asked to change to the output directory, which -after having agreed- will open a new {\em xterm} window. Note that you can always easily change to a output directory by calling
\begin{verbatim}
> lagranto -open local
\end{verbatim}
If several trajectory runs are available in the local directory, you are asked to select one. Often, you would like to see the outcome of a run without changing to the output directory. This is most easily accomplished with the following call:
\begin{verbatim}
> lagranto -show local
\end{verbatim}
\subsection{Start from case directory}
In this calling sequence, for instance
\begin{verbatim}
> lagranto tutorial 19891020_00 19891024_18 startf nil -changet
\end{verbatim}
the input files are not expected in the local directory, but are specified by means of a case identifier. For instance, a case has the identifier {\em tutorial}. Then Lagranto will expect the input netCDF P and S files to be located in
\begin{verbatim}
> ls -l ${HOME}/cdf/tutorial
/home/sprenger/cdf/tutorial/P19891020_00
/home/sprenger/cdf/tutorial/P19891020_06
/home/sprenger/cdf/tutorial/P19891020_12
/home/sprenger/cdf/tutorial/P19891020_18
/home/sprenger/cdf/tutorial/P19891021_00
/home/sprenger/cdf/tutorial/P19891021_06
/home/sprenger/cdf/tutorial/P19891021_12
/hom
\end{verbatim}
and all the other input files (starting positions, tracing file, region file, polygon specification) are expected in
\begin{verbatim}
> ls -l ${HOME}/tra/tutorial
startf
tracevars
\end{verbatim}
The output of the trajectory calculation will be written to the following output directory, where now the case identifier {\em tutorial} is part of the directory name:
\begin{verbatim}
> cd /home/michaesp/tra/tutorial/ntr_19891020_00_f114_tutorial_startf_nil
> ls -1
-rw-r--r-- 1 michaesp wheel 5328945 2011-03-21 14:03 lsl_19891020_00
-rw-r--r-- 1 michaesp wheel 68195 2011-03-21 14:03 runscript.logfile
-rwxr--r-- 1 michaesp wheel 1025 2011-03-21 14:02 runscript.sh*
\end{verbatim}
All other aspects are identical to the ones described in the previous section.
\section{Installation}
In this section you will find some hints how to install Lagranto on a Linux platform. Everthing is handled with the installation script {\em install.sh} which comes with the Lagranto distribution:
\begin{verbatim}
> install.csh
install.sh [lib|core|goodies|links|all]
\end{verbatim}
The installation should proceed in several distinct steps:
\begin{itemize}
\item[a)] Find the place of the netCDF (http://www.unidata.ucar.edu/software/netcdf/) installation on your system - note that the netCDF comes as a pre-compiled package for many Linux distributions and most often can be installed with the Linux software management. Define an environmental variable {\em NETCDF} which directs to your installation, e.g.
\begin{verbatim}
> setenv NETCDF /usr/local/netcdf/
\end{verbatim}
\item[b)] Set the environmental variable {\em LAGRANTO} to the place where you have stored the Lagranto source code and include Lagranto in your search path. In {\em csh} this might look as follows:
\begin{verbatim}
> setenv LAGRANTO /home/michaesp/lagranto/
> set isLAGRANTO=`echo $PATH | grep $LAGRANTO | wc -l`
> if ( $isLAGRANTO == 0 ) then
> setenv PATH $LAGRANTO/bin:${PATH}
> endif
\end{verbatim}
You might include these statements also in your {\em .cshrc} file. If successful, you will then be able to open the lagranto help, e.g. with
\begin{verbatim}
> lagrantohelp
\end{verbatim}
\item[c)] Install the different components of Lagranto and create links - proceed step by step to ensure that each one was successfully completed:
\begin{verbatim}
> install lib
> install core
> install goodies
> install links
\end{verbatim}
\end{itemize}
Lagranto should now be ready to run! As a next step you might want to consider the tutorial, which can be invoked with the command:
\begin{verbatim}
> lagrantohelp tutorial
\end{verbatim}
If you are familiar with the most basic aspects of Lagranto, please refer to the reference guide which enlists all options of Lagranto:
\begin{verbatim}
> lagrantohelp refernce
\end{verbatim}
The contents of the reference guide can also be called from within the Linux shell, e.g. the documentation of {\em caltra} can be seen in man page format with:
\begin{verbatim}
> lagrantohelp caltra
\end{verbatim}
\end{document}

/tags/1.0/goodies/changet.f
0,0 → 1,47
program changetime
C Changes the time value of a NetCDF file.
C-----declarations------------------------------------------------
integer ierr,ntimes
real tstart,time
integer cdfid,varid
character*30 filnam
C-----start of program--------------------------------------------
include 'netcdf.inc'
call ncpopt(NCVERBOS)
read(9,10)filnam
10 format(a30)
read(9,*)time
C Open the data file
cdfid=ncopn(filnam,NCWRITE,ierr)
C Get time value from file
call gettimes(cdfid,tstart,ntimes,ierr)
C Get index for time variable
varid=ncvid(cdfid,'time',ierr)
C Overwrite time-value
call ncvpt1(cdfid,varid,1,time,ierr)
write(*,20)'file ',trim(filnam),' time value changed from ',
> tstart,' to ',time
20 format(a,a,a,f8.2,a,f8.2)
C Close open NetCDF files
call clscdf(cdfid,ierr)
end

/tags/1.0/goodies/changet.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = changet.o ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
changet: $(OBJS)
${F77} -o changet $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/changet.sh
0,0 → 1,41
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
if ( $#argv < 1 ) then
echo
${LAGRANTO}/bin/lagrantohelp changet short
echo
exit 0
endif
set stdate=$1
set fort=fort.9
if ( $#argv == 2 ) then
set string=$2
else
set string='P[_0-9]*[0-9] S[_0-9]*[0-9]'
endif
foreach i ( $string )
\rm -f $fort
touch $fort
# set date = `echo $i | sed -e 's/[A-Za-z_]*//' | cut -c 1-9`
set date = `echo $i | sed -e 's/[A-Za-z_]*//'`
echo $i >> $fort
set date=`echo ${date}00 | cut -c 1-13`
set stdate=`echo ${stdate}00 | cut -c 1-13`
set tim = `${LAGRANTO}/goodies/gettidiff $date $stdate`
echo ${tim} >> $fort
${LAGRANTO}/goodies/changet
end
#\rm -f $fort
Property changes:
Added: svn:executable

/tags/1.0/goodies/datelist.f
0,0 → 1,432
date PROGRAM datelist
c **********************************************************************
c * Handling of date lists *
c * Michael Sprenger *
c **********************************************************************
implicit none
c ---------------------------------------------------------------------
c Declaration of variables
c ---------------------------------------------------------------------
c Parameters
character*80 datefile
character*80 mode
character*80 startdate
character*80 finaldate
character*80 refdate
integer interval
real randpercent
c Date list
integer ndates
integer,allocatable,dimension(:) :: year,month,day,hour
c Auxiliary variables
integer i
integer year1,month1,day1,hour1,min1
integer year2,month2,day2,hour2,min2
character direction
integer date1(5),date2(5)
character*11 datestr,datestr1,datestr2
character ch
real diff
real time
character*80 datefile1,datefile2
integer timestamp1,timestamp2
integer oldstamp1 ,oldstamp2
integer state
c ---------------------------------------------------------------------
c Preparations
c ---------------------------------------------------------------------
c Read parameter file
open(10,file='datelist.param')
read(10,*) datefile ! General parameters
read(10,*) mode
if ( mode.eq.'-create' ) then ! Create date list
read(10,*) startdate
read(10,*) finaldate
read(10,*) interval
elseif ( mode.eq.'-totime' ) then ! Convert to time list
read(10,*) refdate
elseif ( mode.eq.'-todate' ) then ! Convert to date list
read(10,*) refdate
elseif ( mode.eq.'-onlyin1' ) then ! Dates only in file 1
read(10,*) datefile1
read(10,*) datefile2
else ! Invalid mode
print*,' ERROR: invalid mode for datelist'
stop
endif
close(10)
c ---------------------------------------------------------------------
c Create a date list (-create)
c ---------------------------------------------------------------------
if ( mode.ne.'-create' ) goto 100
c Check whether interval is ok
if ( ( interval.le.0 ).or.(interval.gt.24) ) then
print*,'Interval must be between 1 h and 24 h... Stop'
stop
endif
c Extract dates and times
read(startdate( 1: 4),*) year1
read(startdate( 5: 6),*) month1
read(startdate( 7: 8),*) day1
read(startdate(10:11),*) hour1
read(startdate(12:13),*) min1
read(finaldate( 1: 4),*) year2
read(finaldate( 5: 6),*) month2
read(finaldate( 7: 8),*) day2
read(finaldate(10:11),*) hour2
read(finaldate(12:13),*) min2
c Get direction of the date file
if (year2.gt.year1) then
direction = 'f'
goto 101
elseif (year2.lt.year1) then
direction = 'b'
goto 101
endif
if (month2.gt.month1) then
direction = 'f'
goto 101
elseif (month2.lt.month1) then
direction = 'b'
goto 101
endif
if (day2.gt.day1) then
direction = 'f'
goto 101
elseif (day2.lt.day1) then
direction = 'b'
goto 101
endif
if (hour2.gt.hour1) then
direction = 'f'
goto 101
elseif (hour2.lt.hour1) then
direction = 'b'
goto 101
endif
if (min2.gt.min1) then
direction = 'f'
goto 101
elseif (min2.lt.min1) then
direction = 'b'
goto 101
endif
direction = 'f'
101 continue
c Set the interval step depending on the direction
if ( direction.eq.'b' ) then
interval = -interval
endif
c Save the dates in arrays
date1(1) = year1
date1(2) = month1
date1(3) = day1
date1(4) = hour1
date1(5) = 0
date2(1) = year2
date2(2) = month2
date2(3) = day2
date2(4) = hour2
date2(5) = 0
c Get starting and ending date for the date list
if ( direction.eq.'f' ) then
do while ( mod(date1(4),interval) .ne. 0 )
date1(4) = date1(4) - 1
enddo
if (min2.ne.0) call newdate(date2,1.,date2)
do while ( mod(date2(4),interval) .ne. 0 )
date2(4) = date2(4) + 1
enddo
else
if (min1.ne.0) call newdate(date1,1.,date1)
do while ( mod(date1(4),interval) .ne. 0 )
date1(4) = date1(4) + 1
enddo
do while ( mod(date2(4),interval) .ne. 0 )
date2(4) = date2(4) - 1
enddo
endif
c Create and write the datefile
if ( datefile.ne.'/dev/stdout') then
open(10,file=datefile)
endif
102 continue
call datestring(datestr,date1(1),date1(2),date1(3),date1(4) )
if ( datefile.ne.'/dev/stdout') then
write(10,*) datestr
else
write(*,*) datestr
endif
if ( ( date1(1).ne.date2(1) ).or.
> ( date1(2).ne.date2(2) ).or.
> ( date1(3).ne.date2(3) ).or.
> ( date1(4).ne.date2(4) ) )
> then
diff = real(interval)
call newdate(date1,diff,date1)
goto 102
endif
if ( datefile.ne.'/dev/stdout') then
close(10)
endif
100 continue
c ---------------------------------------------------------------------
c Convert dates to a list of times
c ---------------------------------------------------------------------
if ( mode.ne.'-totime' ) goto 110
c Extract reference date
read(refdate( 1: 4),*) year1
read(refdate( 5: 6),*) month1
read(refdate( 7: 8),*) day1
read(refdate(10:11),*) hour1
read(refdate(12:13),*) min1
c Loop through the date file
open(10,file=datefile)
111 read(10,*,end=110) datestr
c Extract date
read(datestr( 1: 4),*) year2
read(datestr( 5: 6),*) month2
read(datestr( 7: 8),*) day2
read(datestr(10:11),*) hour2
min1 = 0
c Get the time difference
date1(1) = year1
date1(2) = month1
date1(3) = day1
date1(4) = hour1
date1(5) = 0
date2(1) = year2
date2(2) = month2
date2(3) = day2
date2(4) = hour2
date2(5) = 0
call timediff(date2,date1,diff)
c Write it to screen
write(*,'(i6)') nint(diff)
goto 111
110 continue
c Close datefile
close(10)
c ---------------------------------------------------------------------
c Convert times to a list of dates
c ---------------------------------------------------------------------
if ( mode.ne.'-todate' ) goto 120
c Extract reference date
read(refdate( 1: 4),*) year1
read(refdate( 5: 6),*) month1
read(refdate( 7: 8),*) day1
read(refdate(10:11),*) hour1
read(refdate(12:13),*) min1
c Loop through the date file
open(10,file=datefile)
121 read(10,*,end=120) time
c Calculate the new date
date1(1) = year1
date1(2) = month1
date1(3) = day1
date1(4) = hour1
date1(5) = 0
call newdate(date1,time,date2)
call datestring(datestr,date2(1),date2(2),date2(3),date2(4) )
c Write it to screen
write(*,'(a11)') trim(datestr)
goto 121
120 continue
c Close datefile
close(10)
c ---------------------------------------------------------------------
c Extract all dates which are only in one datefile
c ---------------------------------------------------------------------
if ( mode.ne.'-onlyin1' ) goto 130
c Set reference date
date1(1) = 1979
date1(2) = 1
date1(3) = 1
date1(4) = 0
date1(5) = 0
c Open the output file
if ( datefile.ne.'/dev/stdout') then
open(30,file=datefile)
endif
c Loop through the input date files
open(10,file=datefile1)
open(20,file=datefile2)
c Loop through both date files
state = 0
oldstamp1 = 0
oldstamp2 = 0
131 if ( (state.eq.1).or.(state.eq.0) ) then
read(10,*,end=133) datestr1
endif
if ( (state.eq.2).or.(state.eq.0) ) then
read(20,*,end=130) datestr2
endif
c Get time stamp for both date strings
if ( (state.eq.1).or.(state.eq.0) ) then
read(datestr1( 1: 4),*) year2
read(datestr1( 5: 6),*) month2
read(datestr1( 7: 8),*) day2
read(datestr1(10:11),*) hour2
date2(1) = year2
date2(2) = month2
date2(3) = day2
date2(4) = hour2
date2(5) = 0
call timediff(date2,date1,diff)
timestamp1 = nint( diff )
if ( timestamp1.lt.oldstamp1 ) then
print*,' ERROR: datelist must be ordered ',trim(datefile1)
stop
else
oldstamp1 = timestamp1
endif
endif
if ( (state.eq.1).or.(state.eq.0) ) then
read(datestr2( 1: 4),*) year2
read(datestr2( 5: 6),*) month2
read(datestr2( 7: 8),*) day2
read(datestr2(10:11),*) hour2
date2(1) = year2
date2(2) = month2
date2(3) = day2
date2(4) = hour2
date2(5) = 0
call timediff(date2,date1,diff)
timestamp2 = nint( diff )
if ( timestamp2.lt.oldstamp2 ) then
print*,' ERROR: datelist must be ordered ',trim(datefile2)
stop
else
oldstamp2 = timestamp2
endif
endif
c Write output and set new state
if ( timestamp1.gt.timestamp2 ) then
state = 2
c print*,trim(datestr1)//'.'//trim(datestr2)//' >'
else if ( timestamp1.lt.timestamp2 ) then
state = 1
if ( datefile.ne.'/dev/stdout') then
write(30,*) datestr1
else
write(*,*) datestr1
endif
c print*,trim(datestr1)//'.'//trim(datestr2)//' -> out'
else if (timestamp1.eq.timestamp2 ) then
state = 0
c print*,trim(datestr1)//'.'//trim(datestr2)//' ='
endif
goto 131
c Exit point for parallel reading through files
130 continue
c Write remaining part of datefile 1
132 continue
read(10,*,end=133) datestr1
if ( datefile.ne.'/dev/stdout') then
write(30,*) datestr1
else
write(*,*) datestr1
endif
goto 132
133 continue
c Close datefile
close(10)
close(20)
close(30)
c ---------------------------------------------------------------------
c End
c ---------------------------------------------------------------------
end

/tags/1.0/goodies/datelist.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = datelist.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
datelist: $(OBJS)
${F77} -o datelist $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/datelist.sh
0,0 → 1,268
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp datelist short
echo
exit 0
endif
# Handle fixed arguments
set filename = $1
set mode = $2
# Redirect output to screen if requested
if ( "${filename}" == "stdout" ) set filename="/dev/stdout"
if ( "${filename}" == "screen" ) set filename="/dev/stdout"
# Handle optional arguments
set interval = "6"
while ( $#argv > 0 )
switch ( $argv[1] )
case -create
set startdate = $argv[2]
set finaldate = $argv[3]
shift;
shift;
breaksw
case -indir
set dirname = $argv[2]
shift;
breaksw
case -next
set date = $argv[2]
shift;
breaksw
case -prev
set date = $argv[2]
shift;
breaksw
case -isin
set date = $argv[2]
shift;
breaksw
case -interval
set interval = $argv[2]
shift;
breaksw
case -overlap
set file1 = $argv[2]
set file2 = $argv[3]
shift;
shift;
breaksw
case -onlyin1
set file1 = $argv[2]
set file2 = $argv[3]
shift;
shift;
breaksw
case -onlyin2
set file1 = $argv[2]
set file2 = $argv[3]
shift;
shift;
breaksw
case -totime
set refdate = $argv[2]
shift;
breaksw
case -todate
set refdate = $argv[2]
shift;
breaksw
endsw
shift;
end
# Mode: -create startdate finaldate
if ( "${mode}" == "-create" ) then
\rm -f datelist.param
echo \"${filename}\" > datelist.param
echo \"${mode}\" >> datelist.param
echo \"${startdate}00\" >> datelist.param
echo \"${finaldate}00\" >> datelist.param
echo ${interval} >> datelist.param
${LAGRANTO}/goodies/datelist
endif
# Mode: -first
if ( "${mode}" == "-first" ) then
head -1 ${filename}
endif
# Mode: -last
if ( "${mode}" == "-last" ) then
tail -1 ${filename}
endif
# Mode: -ndates
if ( "${mode}" == "-ndates" ) then
wc -l ${filename} | awk '{ print $1}'
endif
# Mode: -timerange
if ( "${mode}" == "-timerange" ) then
set firstdate = `head -1 ${filename}`
set finaldate = `tail -1 ${filename}`
${LAGRANTO}/goodies/gettidiff ${finaldate} ${firstdate}
endif
# Mode: -indir {directory name}
if ( "${mode}" == "-indir" ) then
ls -1 ${dirname} | perl -ne 'print if s/.*([0-9]{8}_[0-9]{2}).*/\1/' | sort | uniq >! ${filename}
endif
# Mode: -next
if ( "${mode}" == "-next" ) then
set last = `tail -1 ${filename}`
if ( "${date}" != "${last}" ) then
set next = `sed -n "/${date}/{n;p;}" ${filename}`
echo ${next}
else
echo "nil"
endif
endif
# Mode: -prev
if ( "${mode}" == "-prev" ) then
set first = `head -1 ${filename}`
if ( "${date}" != "${first}" ) then
set prev = `sed -n "/${date}/{g;p;};h" ${filename}`
echo ${prev}
else
echo "nil"
endif
endif
# Mode: -isin
if ( "${mode}" == "-isin" ) then
set flag = `sed -n "/${date}/p" ${filename}`
if ( "${flag}" != "" ) then
echo "1"
else
echo "0"
endif
endif
# Mode: -overlap
if ( "${mode}" == "-overlap" ) then
if ( "${filename}" != "/dev/stdout" ) then
set outfile = ${filename}.$$
\rm -f ${outfile}
grep -f ${file1} ${file2} > ${outfile}
\mv ${outfile} ${filename}
else
grep -f ${file1} ${file2}
endif
endif
# Mode: -onlyin1
if ( "${mode}" == "-onlyin1" ) then
\rm -f datelist.param
echo \"${filename}\" > datelist.param
echo \"${mode}\" >> datelist.param
echo \"${file1}\" >> datelist.param
echo \"${file2}\" >> datelist.param
${LAGRANTO}/goodies/datelist
endif
# Mode: -onlyin2
if ( "${mode}" == "-onlyin2" ) then
set outfile1 = "tmp1.$$"
set outfile2 = "tmp2.$$"
\rm -f ${outfile1}
\rm -f ${outfile2}
grep -f ${file2} ${file1} >! ${outfile1}
grep -vf ${outfile1} ${file2} >! ${outfile2}
if ( "${filename}" != "/dev/stdout" ) then
\mv ${outfile2} ${filename}
else
cat ${outfile2}
endif
\rm -f ${outfile1}
\rm -f ${outfile2}
endif
# Mode: -totime
if ( "${mode}" == "-totime" ) then
\rm -f datelist.param
echo \"${filename}\" > datelist.param
echo \"${mode}\" >> datelist.param
echo \"${refdate}00\" >> datelist.param
${LAGRANTO}/goodies/datelist
endif
# Mode: -todate
if ( "${mode}" == "-todate" ) then
\rm -f datelist.param
echo \"${filename}\" > datelist.param
echo \"${mode}\" >> datelist.param
echo \"${refdate}00\" >> datelist.param
${LAGRANTO}/goodies/datelist
endif
# Mode: -randsample
if ( "${mode}" == "-randsample" ) then
\rm -f datelist.param
echo \"${filename}\" > datelist.param
echo \"${mode}\" >> datelist.param
echo ${randsample} >> datelist.param
${LAGRANTO}/goodies/datelist
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/difference.f
0,0 → 1,326
PROGRAM difference
c ***********************************************************************
c * Get the difference between tow trajectory files *
c * Michael Sprenger / Spring, summer, autumn 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Field name and mode for difference calculation
character*80 mode ! Difference mode
character*80 fieldname ! Name of differencing
c Input and output format for trajectories (see iotra.f)
character*80 inpfile1 ! Input filename 1
character*80 inpfile2 ! Input filename 2
character*80 outfile ! Output filename
c Input trajectories
integer ntra1 ,ntra2 ! Number of trajectories
integer ntim1 ,ntim2 ! Number of times
integer ncol1 ,ncol2 ! Number of columns
real,allocatable, dimension (:,:,:) :: trainp1 ,trainp2 ! Trajectories (ntra,ntim,ncol)
character*80 vars1(100) ,vars2(100) ! Variable names
integer refdate1(6),refdate2(6) ! Reference date
c Output/comparison trajectory
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
real,allocatable, dimension (:,:,:) :: traout ! Trajectories (ntra,ntim,ncol)
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
c Auxiliary variables
integer inpmode1,inpmode2
integer outmode
integer stat
integer fid
integer i,j,k
integer ind1,ind2
integer isok
character ch
real,allocatable, dimension (:) :: diff
integer outind
c Externals
real,external :: sdis
c ----------------------------------------------------------------------
c Preparations
c ----------------------------------------------------------------------
c Read parameters
open(10,file='difference.param')
read(10,*) inpfile1
read(10,*) inpfile2
read(10,*) outfile
read(10,*) ntra1,ntim1,ncol1
read(10,*) ntra2,ntim2,ncol2
read(10,*) mode
read(10,*) fieldname
close(10)
c Determine the formats
call mode_tra(inpmode1,inpfile1)
if (inpmode1.eq.-1) inpmode1=1
call mode_tra(inpmode2,inpfile2)
if (inpmode2.eq.-1) inpmode2=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c Set number of trajectories for output
if ( ntra1.lt.ntra2) then
ntra = ntra1
else
ntra = ntra2
endif
c Set number of times for output
if ( mode.eq.'single' ) then
ntim = ntim1
else
ntim = 1
endif
c Set the column names for output
if ( fieldname.eq.'LATLON') then
ncol = 1 + 3 + 3 + 1
vars(1) = 'time'
vars(2) = 'lon[1]'
vars(3) = 'lat[1]'
vars(4) = 'p[1]'
vars(5) = 'lon[2]'
vars(6) = 'lat[2]'
vars(7) = 'p[2]'
vars(8) = 'SDIS'
else
ncol = 1 + 3 + 3 + 2 + 1
vars( 1) = 'time'
vars( 2) = 'lon[1]'
vars( 3) = 'lat[1]'
vars( 4) = 'p[1]'
vars( 5) = 'lon[2]'
vars( 6) = 'lat[2]'
vars( 7) = 'p[2]'
vars( 8) = trim(fieldname)//'[1]'
vars( 9) = trim(fieldname)//'[2]'
vars(10) = trim(fieldname)//'[1-2]'
endif
c Allocate memory
allocate(trainp1(ntra1,ntim1,ncol1),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp1 ***'
allocate(trainp2(ntra2,ntim2,ncol2),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp2 ***'
allocate(traout(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traout ***'
allocate(diff(ntim1),stat=stat)
if (stat.ne.0) print*,'*** error allocating array diff ***'
c Read inpufiles
call ropen_tra(fid,inpfile1,ntra1,ntim1,ncol1,
> refdate1,vars1,inpmode1)
call read_tra (fid,trainp1,ntra1,ntim1,ncol1,inpmode1)
call close_tra(fid,inpmode1)
call ropen_tra(fid,inpfile2,ntra2,ntim2,ncol2,
> refdate2,vars2,inpmode2)
call read_tra (fid,trainp2,ntra2,ntim2,ncol2,inpmode2)
call close_tra(fid,inpmode2)
c Check dimensions of the two trajectory files (#tim hard check)
if (ntim1.ne.ntim2) then
print*,'Trajectoy files have different time dimensions... Stop'
stop
endif
c Check dimensions of the two trajectory files (#tra soft check)
if (ntra1.ne.ntra2) then
print*,'Differing number of trajectories... proceed [y/n]'
read*,ch
if (ch.eq.'n') stop
endif
c Check whether difference field is available on both files
if ( fieldname.ne.'LATLON') then
ind1 = 0
ind2 = 0
do i=1,ncol
if ( fieldname.eq.vars1(i) ) ind1 = i
if ( fieldname.eq.vars2(i) ) ind2 = i
enddo
if ( (ind1.eq.0).or.(ind2.eq.0) ) then
print*,'Field ',trim(fieldname),' not available... Stop'
stop
endif
endif
c Check reference dates (soft check)
isok = 1
do i=1,6
if ( refdate1(i).ne.refdate2(i) ) isok = 0
enddo
if ( isok.eq.0 ) then
print*,'Warning: reference dates differ... proceed [y/n]'
read*,ch
if (ch.eq.'n') stop
endif
c Check trajectory times (soft check)
isok = 1
do i=1,ntim
if ( trainp1(1,i,1).ne.trainp2(1,i,1) ) isok = 0
enddo
if ( isok.eq.0 ) then
print*,'Warning: trajectory times differ... proceed [y/n]'
read*,ch
if (ch.eq.'n') stop
endif
c Copy reference date to output
do i=1,6
refdate(i) = refdate1(i)
enddo
c ----------------------------------------------------------------------
c Calculate the difference (depending on mode)
c ----------------------------------------------------------------------
c Loop over all trajectories
do i=1,ntra
c Calculate difference for all times
do j=1,ntim1
c Calculate the difference (distance or absolute value)
if (fieldname.eq.'LATLON') then
diff(j) = sdis( trainp1(i,j,2),trainp1(i,j,3),
> trainp2(i,j,2),trainp2(i,j,3) )
else
diff(j) = abs(trainp1(i,j,ind1) - trainp2(i,j,ind2))
endif
enddo
c Save output for each time
if ( mode.eq.'single' ) then
do j=1,ntim
if ( fieldname.eq.'LATLON' ) then
traout(i,j, 1) = trainp1(i,j,1) ! time
traout(i,j, 2) = trainp1(i,j,2) ! lon[1]
traout(i,j, 3) = trainp1(i,j,3) ! lat[1]
traout(i,j, 4) = trainp1(i,j,4) ! p[1]
traout(i,j, 5) = trainp2(i,j,2) ! lon[2]
traout(i,j, 6) = trainp2(i,j,3) ! lat[2]
traout(i,j, 7) = trainp2(i,j,4) ! p[2]
traout(i,j, 8) = diff(j) ! SDIS(j)
else
traout(i,j, 1) = trainp1(i,j,1) ! time
traout(i,j, 2) = trainp1(i,j,2) ! lon[1]
traout(i,j, 3) = trainp1(i,j,3) ! lat[1]
traout(i,j, 4) = trainp1(i,j,4) ! p[1]
traout(i,j, 5) = trainp2(i,j,2) ! lon[2]
traout(i,j, 6) = trainp2(i,j,3) ! lat[2]
traout(i,j, 7) = trainp2(i,j,4) ! p[2]
traout(i,j, 8) = trainp1(i,j,ind1) ! field[1]
traout(i,j, 9) = trainp2(i,j,ind2) ! field[2]
traout(i,j,10) = diff(j) ! SDIS(j)
endif
enddo
c Save only maximum
elseif ( mode.eq.'max') then
outind = 1
do j=2,ntim1
if ( diff(j).gt.diff(outind) ) outind = j
enddo
if ( fieldname.eq.'LATLON' ) then
traout(i,1, 1) = trainp1(i,outind,1) ! time
traout(i,1, 2) = trainp1(i,outind,2) ! lon[1]
traout(i,1, 3) = trainp1(i,outind,3) ! lat[1]
traout(i,1, 4) = trainp1(i,outind,4) ! p[1]
traout(i,1, 5) = trainp2(i,outind,2) ! lon[2]
traout(i,1, 6) = trainp2(i,outind,3) ! lat[2]
traout(i,1, 7) = trainp2(i,outind,4) ! p[2]
traout(i,1, 8) = diff(outind) ! SDIS
else
traout(i,1, 1) = trainp1(i,outind,1) ! time
traout(i,1, 2) = trainp1(i,outind,2) ! lon[1]
traout(i,1, 3) = trainp1(i,outind,3) ! lat[1]
traout(i,1, 4) = trainp1(i,outind,4) ! p[1]
traout(i,1, 5) = trainp2(i,outind,2) ! lon[2]
traout(i,1, 6) = trainp2(i,outind,3) ! lat[2]
traout(i,1, 7) = trainp2(i,outind,4) ! p[2]
traout(i,1, 8) = trainp1(i,outind,ind1) ! field[1]
traout(i,1, 9) = trainp2(i,outind,ind2) ! field[2]
traout(i,1,10) = diff(outind) ! SDIS(j)
endif
endif
enddo
c ----------------------------------------------------------------------
c Write output
c ----------------------------------------------------------------------
c Write output file
call wopen_tra(fid,outfile,ntra,ntim,ncol,refdate,vars,outmode)
call write_tra(fid,traout,ntra,ntim,ncol,outmode)
call close_tra(fid,outmode)
end
c ***********************************************************************
c * Subroutines *
c ***********************************************************************
c ----------------------------------------------------------------------
c Spherical distance
c ----------------------------------------------------------------------
real function sdis(xp,yp,xq,yq)
c
c calculates spherical distance (in km) between two points given
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
c
real pi180
parameter (pi180=3.14159/180.)
real re
parameter (re=6370.)
real degkm
parameter (degkm=111.1775)
real xp,yp,xq,yq,arg
if ( (abs(xp-xq).gt.0.05).and.(abs(yp-yq).gt.0.05) ) then
arg=sin(pi180*yp)*sin(pi180*yq)+
> cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
if (arg.lt.-1.) arg=-1.
if (arg.gt.1.) arg=1.
sdis=re*acos(arg)
else
sdis= (yp-yq)**2 + ( (xp-xq) * cos( pi180*0.5*(yp+yq) ) )**2
sdis = deg2km * sqrt(sdis)
endif
end

/tags/1.0/goodies/difference.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = difference.o ${LAGRANTO}/lib//iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
difference: $(OBJS)
${F77} -o difference $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/difference.sh
0,0 → 1,62
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp difference short
echo
exit 0
endif
# Get input and output trajectory file
set inpfile1 = $1
set inpfile2 = $2
set outfile = $3
set fieldname = $4
# Handle optional arguments
set mode = "single"
while ( $#argv > 0 )
switch ( $argv[1] )
case -single
set mode = "single"
breaksw
case -max
set mode = "max"
breaksw
endsw
shift;
end
# Get the dimensions of the trajectory files
set dim1=`${LAGRANTO}/goodies/trainfo.sh ${inpfile1} dim`
set dim2=`${LAGRANTO}/goodies/trainfo.sh ${inpfile2} dim`
# Prepare parameter file and run program
\rm -f difference.param
echo \"${inpfile1}\" >! difference.param
echo \"${inpfile2}\" >> difference.param
echo \"${outfile}\" >> difference.param
echo ${dim1} >> difference.param
echo ${dim2} >> difference.param
echo \"${mode}\" >> difference.param
echo \"${fieldname}\" >> difference.param
${LAGRANTO}/goodies/difference
# Make clean
#\rm -f difference.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/evalmod.f90
0,0 → 1,931
module evaluate
! The user can assign values to parameters that can be used in expressions with
! the subroutine defparam. The calling syntax is
!
! call defparam(symbol,value) or call defparam(symbol,expr)
!
! where symbol is the desired parameter name; value is a real, integer, or
! complex variable (single or double precision); and expr is a string
! containing an expression to be evaluated. The value obtained by evaluating the
! expression expr is associated with the parameter symbol. Parameter names must
! begin with a letter (a-z, A-Z) and must not be longer than 24 characters.
! Parameter names are not case dependent.
!
! An expression can be evaluated with the subroutine evalexpr. The calling
! syntax is
!
! call evalexpr(expr,value)
!
! where expr is a string containing the expression to be evaluated; value is the
! result (single or double precision real, complex or integer). The
! expression can contain the arithmetic operations +, -, *, /, or ^ as well as
! the functions sin, cos, tan, log, ln, abs, exp, sqrt, real, imag, conjg, and
! ang (the function ang calculates the phase angle of its complex argument). The
! expression can also contain numerical values and previously defined parameters
! Grouping by nested levels of parentheses is also allowed. The parameters pi
! and i (imaginary unit) are predefined. Complex numbers can be entered as a+i*b
! if the parameter i has not been redefined by the user. Complex numbers can also
! be entered using complex(a,b).
! Example expression:
!
! conjg(((cos(x) + sqrt(a+i*b))^2+complex(ln(1.6e-4),20))/2)
!
! An equation of the form <symbol> = <expression> can be evaluated using the
! subroutine evaleqn. The calling syntax is
!
! call evaleqn(eqn)
!
! where eqn is a string containing the equation. The right-hand-side of the
! equation is evaluated and assigned to the symbol given by the left-hand-side.
!
! The value assigned to a symbol can be retrieved using the subroutine getparam.
! The calling syntax is
!
! call getparam(sym,value)
!
! where sym is a symbol string; value is a numeric variable (any of the six
! standard types).
!
! The symbols and their values in the symbol table can be listed using the
! subroutine listvar. The variable ierr is always available following a call
! to any of the above subroutines and is zero if there were no errors. The
! possible nonzero values for ierr are
!
! 1 Expression empty
! 2 Parentheses don't match
! 3 Number string does not correspond to a valid number
! 4 Undefined symbol
! 5 Less than two operands for binary operation
! 6 No operand for unary plus or minus operators
! 7 No argument(s) for function
! 8 Zero or negative real argument for logarithm
! 9 Negative real argument for square root
! 10 Division by zero
! 11 Improper symbol format
! 12 Missing operator
! 13 Undefined function
! 14 Argument of tangent function a multiple of pi/2
!
use precision
use strings
save
private
public :: valuep,evalexpr,defparam,evaleqn,getparam,listvar,ierr
type item
character(len=24):: char
character :: type
end type item
type param
character (len=24):: symbol
complex(kc8):: value
end type param
interface defparam
module procedure strdef ! value given by expression
module procedure valdef_dc ! Double precision complex value
module procedure valdef_sc ! Single precision complex value
module procedure valdef_dr ! Double precision real value
module procedure valdef_sr ! Single precision real value
module procedure valdef_di ! Double precision integer value
module procedure valdef_si ! Single precision integer value
end interface
interface evalexpr
module procedure evalexpr_dc ! Double precision complex result
module procedure evalexpr_sc ! Single precision complex result
module procedure evalexpr_dr ! Double precision real result
module procedure evalexpr_sr ! Single precision real result
module procedure evalexpr_di ! Double precision integer result
module procedure evalexpr_si ! Single precision integer result
end interface
interface getparam
module procedure getparam_dc ! Double precision complex result
module procedure getparam_sc ! Single precision complex result
module procedure getparam_dr ! Double precision real result
module procedure getparam_sr ! Single precision real result
module procedure getparam_di ! Double precision integer result
module procedure getparam_si ! Single precision integer result
end interface
integer,parameter :: numtok=100 ! Maximum number of tokens
type(param) :: params(100) ! Symbol table
integer :: nparams=0,itop,ibin
complex(kc8) :: valstack(numtok) ! Stack used in evaluation of expression
type(item):: opstack(numtok) ! Operator stack used in conversion to postfix
integer :: ierr ! Error flag
!**********************************************************************
contains
!**********************************************************************
SUBROUTINE EVALEXPR_DC(expr,val) ! Evaluate expression expr for
! val double precision complex
character (len=*),intent(in) :: expr
complex(kc8) :: val
character (len=len(expr)+1) :: tempstr
character :: cop
integer :: isp(numtok) ! On stack priority of operators in opstack
integer :: lstr
complex(kc8) :: cval,oper1,oper2
real(kr8) :: valr,vali
type(item):: token(numtok) ! List of tokens ( a token is an operator or
! operand) in postfix order
type(item) :: x,junk,tok
ierr=0
token(1:)%char=' '
if(nparams == 0) then ! Initialize symbol table
params(1)%symbol='PI'
params(1)%value=(3.14159265358979_kr8,0.0_kr8)
params(2)%symbol='I'
params(2)%value=(0.0_kr8,1.0_kr8)
nparams=2
end if
if(len_trim(expr) == 0) then ! Expression empty
ierr=1
write(*,*) 'Error: expression being evaluated is empty'
return
end if
tempstr=adjustl(expr)
call removesp(tempstr) ! Removes spaces, tabs, and control characters
! ****************************************************************************
! STEP 1: Convert string to token array. Each token is either an operator or
! an operand. Token array will be in postfix (reverse Polish) order.
!*****************************************************************************
ntok=0
ibin=0
itop=0
do
lstr=len_trim(tempstr)
call get_next_token(tempstr(1:lstr),tok,icp,insp)
select case(tok%type)
case('S')
ntok=ntok+1
token(ntok)=tok
case('E')
do
if(itop < 1)exit
call popop(x) ! Output remaining operators on stack
ntok=ntok+1
token(ntok)=x
end do
ntok=ntok+1
token(ntok)=tok
exit
case('R') ! Token is right parenenthesis
do
if(opstack(itop)%type == 'L') exit ! Output operators on stack down
call popop(x) ! to left parenthesis
ntok=ntok+1
token(ntok)=x
end do
call popop(junk) ! Remove left parenthesis from stack
if(opstack(itop)%type == 'F') then ! Output function name if present
call popop(x)
ntok=ntok+1
token(ntok)=x
end if
case('D') ! Token is comma
do
if(opstack(itop)%type == 'L') exit ! Output operators on stack down
call popop(x) ! to left parenthesis
ntok=ntok+1
token(ntok)=x
end do
case('U','B','L','F') ! Token is operator, left parenthesis or function name
do
if(isp(itop) < icp) exit ! Output operators on stack having
call popop(x) ! an instack priority that is
ntok=ntok+1 ! greater than or equal to the
token(ntok)=x ! priority of the incoming operator
end do
call pushop(tok) ! Put incoming operator on stack
isp(itop)=insp
end select
end do
isum=0 ! Error check for matching parentheses
do i=1,ntok
if(token(i)%type == 'L' ) isum=isum+1
if(token(i)%type == 'R' ) isum=isum-1
end do
if(isum /= 0) then
ierr=2
write(*,*) 'Error in the evaluation of the expression ',trim(expr)
write(*,*) "Parentheses don't match"
write(*,*)
return
end if
!*****************************************************************************
! STEP 2: Evaluate token string in postfix order
!*****************************************************************************
itop=0
do i=1,ntok
x=token(i)
select case(x%type)
case('E') ! Token is end token
if(itop>1) then
ierr=12
write(*,*) 'Error: missing operator in expression ',trim(expr)
write(*,*)
return
end if
call popval(val) ! Final result left on stack of values
exit
case('S') ! Token is operand
call valuep(x%char,cval) ! Evaluate operand
if(ierr/=0) return
call pushval(cval) ! Put value of operand on stack
case('B') ! Token is a binary operator
if(itop < 2) then
ierr=5
write(*,*) 'Error in evaluation of expression ',trim(expr)
write(*,*) 'Less than two operands for binary operator '&
,trim(x%char)
write(*,*)
return
end if
call popval(oper1) ! Pull off top two values from stack
call popval(oper2)
select case(trim(x%char)) ! Perform operation on values
case('^')
cval=oper2**oper1
case('*')
cval=oper2*oper1
case('/')
if(oper1 == (0._kr8,0._kr8)) then
ierr=10
write(*,*) 'Error in expression ',trim(expr)
write(*,*) 'Division by zero'
write(*,*)
return
end if
cval=oper2/oper1
case('+')
cval=oper2+oper1
case('-')
cval=oper2-oper1
end select
call pushval(cval) ! Put result back on stack
case('U') ! Token is unary operator
if(itop == 0) then
ierr=6
write(*,*) 'Error in expression ',trim(expr)
write(*,*) 'No operand for unary operator ',trim(x%char)
write(*,*)
return
else
call popval(oper1) ! Pull top value off stack
end if
select case(trim(x%char)) ! Operate on value
case('+')
cval=oper1
case('-')
cval=-oper1
end select
call pushval(cval) ! Put result back on stack
case('F') ! Token is a function name
if(itop == 0) then
ierr=7
write(*,*) 'Error in expression ',trim(expr)
write(*,*) 'Missing argument(s) for function ',trim(x%char)
write(*,*)
return
else
call popval(oper1) ! Pull top value off stack
end if
tempstr=uppercase(x%char)
select case(trim(tempstr)) ! Evaluate function
case('SIN')
cval=sin(oper1)
case('COS')
cval=cos(oper1)
case('TAN')
oper2=cos(oper1)
if(abs(oper2) == 0.0_kr8) then
ierr=14
write(*,*) 'Error: argument of tan function a multiple',&
' of pi/2 in expression ',trim(expr)
write(*,*)
return
else
cval=sin(oper1)/oper2
endif
case('SQRT')
if(real(oper1,kr8) < 0. .and. aimag(oper1)==0.) then
ierr=9
write(*,*) 'Warning: square root of negative real number',&
' in expression ',trim(expr)
write(*,*)
end if
cval=sqrt(oper1)
case('ABS')
cval=abs(oper1)
case('LN')
if(real(oper1,kr8) <= 0. .and. aimag(oper1)==0.) then
ierr=8
write(*,*) 'Error: negative real or zero argument for',&
' natural logarithm in expression ',trim(expr)
write(*,*)
return
end if
cval=log(oper1)
case('LOG')
if(real(oper1,kr8) <= 0. .and. aimag(oper1)==0.) then
ierr=8
write(*,*) 'Error: negative real or zero argument for base',&
'10 logarithm in expression ',trim(expr)
write(*,*)
return
end if
cval=log(oper1)/2.30258509299405_kr8
case('EXP')
cval=exp(oper1)
case('COMPLEX')
if(itop == 0) then
ierr=7
write(*,*) 'Error in expression ',trim(expr)
write(*,*) 'Missing argument(s) for function ',trim(x%char)
write(*,*)
return
else
call popval(oper2) ! Pull second argument off stack
end if
valr=real(oper2,kr8)
vali=real(oper1,kr8)
cval=cmplx(valr,vali,kc8)
case('CONJG')
cval=conjg(oper1)
case('ANG')
cval=atan2(aimag(oper1),real(oper1,kr8))
case('REAL')
cval=real(oper1,kr8)
case('IMAG')
cval=aimag(oper1)
case default ! Undefined function
ierr=13
write(*,*) 'Error: the function ',trim(x%char), ' is undefined',&
' in the expression ',trim(expr)
write(*,*)
return
end select
call pushval(cval) ! Put result back on stack
end select
end do
end subroutine evalexpr_dc
!**********************************************************************
SUBROUTINE GET_NEXT_TOKEN(str,tok,icp,isp)
character(len=*) :: str
character :: cop,chtemp
type(item) :: tok
integer :: icp
lstr=len_trim(str)
if(lstr == 0) then
tok%char='#' ! Output end token
tok%type='E'
return
end if
ipos=scan(str,'+-*/^(),') ! Look for an arithmetic operator
! + - * / ^ ( ) or ,
cop=str(ipos:ipos)
select case (ipos)
case(0) ! Operators not present
ntok=ntok+1
tok%char=str
tok%type='S'
str=''
icp=0
isp=0
case(1)
tok%char=cop
select case(cop)
case('+','-')
if(ibin==0) then
tok%type='U'
icp=4
isp=3
else
tok%type='B'
icp=1
isp=1
end if
ibin=0
case('*','/')
tok%type='B'
icp=2
isp=2
ibin=0
case('^')
tok%type='B'
icp=4
isp=3
ibin=0
case('(')
tok%type='L'
icp=4
isp=0
ibin=0
case(')')
tok%type='R'
icp=0
isp=0
ibin=1
case(',')
tok%type='D'
icp=0
isp=0
ibin=0
end select
str=str(2:)
case(2:)
select case(cop)
case('(')
tok%char=str(1:ipos-1)
tok%type='F'
icp=4
isp=0
ibin=0
str=str(ipos:)
case('+','-')
chtemp=uppercase(str(ipos-1:ipos-1))
if(is_letter(str(1:1)).eqv..true. .or. chtemp/='E') then
tok%char=str(1:ipos-1)
tok%type='S'
icp=0
isp=0
ibin=1
str=str(ipos:)
else
inext=scan(str(ipos+1:),'+-*/^(),')
if(inext==0) then
tok%char=str
tok%type='S'
icp=0
isp=0
ibin=0
str=''
else
tok%char=str(1:ipos+inext-1)
tok%type='S'
icp=0
isp=0
ibin=1
str=str(ipos+inext:)
end if
end if
case default
tok%char=str(1:ipos-1)
tok%type='S'
icp=0
isp=0
ibin=1
str=str(ipos:)
end select
end select
end subroutine get_next_token
!**********************************************************************
SUBROUTINE EVALEXPR_SC(expr,val) ! Evaluate expression expr for
! val single precision complex
character(len=*) :: expr
complex(kc4) :: val
complex(kc8) :: vald
call evalexpr_dc(expr,vald)
val=vald
end subroutine evalexpr_sc
!**********************************************************************
SUBROUTINE EVALEXPR_SR(expr,val) ! Evaluate expression expr for
! val single precision real
character(len=*) :: expr
real(kr4) :: val
complex(kc8) :: vald
call evalexpr_dc(expr,vald)
val=real(vald)
end subroutine evalexpr_sr
!**********************************************************************
SUBROUTINE EVALEXPR_DR(expr,val) ! Evaluate expression expr for
! val double precision real
character(len=*) :: expr
real(kr8) :: val
complex(kc8) :: vald
call evalexpr_dc(expr,vald)
val=real(vald,kr8)
end subroutine evalexpr_dr
!**********************************************************************
SUBROUTINE EVALEXPR_SI(expr,ival) ! Evaluate expression expr for
! ival single precision integer
character(len=*) :: expr
integer(ki4) :: ival
complex(kc8) :: vald
call evalexpr_dc(expr,vald)
ival=nint(real(vald,kr8),ki4)
end subroutine evalexpr_si
!**********************************************************************
SUBROUTINE EVALEXPR_DI(expr,ival) ! Evaluate expression expr for
! ival double precision integer
character(len=*) :: expr
integer(ki8) :: ival
complex(kc8) :: vald
call evalexpr_dc(expr,vald)
ival=nint(real(vald,kr8),ki8)
end subroutine evalexpr_di
!**********************************************************************
SUBROUTINE VALDEF_DC(sym,val) ! Associates sym with val in symbol table,
! val double precision complex
character(len=*) :: sym
character(len=len_trim(sym)) :: usym
complex(kc8) :: val
ierr=0
if(nparams == 0) then ! Initialize symbol table
params(1)%symbol='PI'
params(1)%value=(3.14159265358979_kr8,0.0_kr8)
params(2)%symbol='I'
params(2)%value=(0.0_kr8,1.0_kr8)
nparams=2
end if
! Assign val to sym if sym is already in symbol table
usym=uppercase(sym)
if(is_letter(sym(1:1)).eqv..false. .or. len_trim(sym)>24) then
ierr=11
write(*,*) 'Error: symbol ',trim(sym),' has improper format'
write(*,*)
return
end if
do i=1,nparams
if(trim(usym)==trim(params(i)%symbol)) then
params(i)%value=val
return
end if
end do
nparams=nparams+1 ! Otherwise assign val to new symbol sym
params(nparams)%symbol=usym
params(nparams)%value=val
end subroutine valdef_dc
!**********************************************************************
SUBROUTINE VALDEF_SC(sym,val) ! Associates sym with val in symbol table,
! val single precision complex
character(len=*) :: sym
complex(kc4) :: val
complex(kc8) :: vald
vald=val
call valdef_dc(sym,vald)
end subroutine valdef_sc
!**********************************************************************
SUBROUTINE VALDEF_DR(sym,val) ! Associates sym with val in symbol table,
! val double precision real
character(len=*) :: sym
real(kr8) :: val
complex(kc8) :: vald
vald=cmplx(val,0.0_kr8,kc8)
call valdef_dc(sym,vald)
end subroutine valdef_dr
!**********************************************************************
SUBROUTINE VALDEF_SR(sym,val) ! Associates sym with val in symbol table,
! val single precision real
character(len=*) :: sym
real(kr4) :: val
complex(kc8) :: vald
vald=cmplx(val,0.0,kc8)
call valdef_dc(sym,vald)
end subroutine valdef_sr
!**********************************************************************
SUBROUTINE VALDEF_DI(sym,ival) ! Associates sym with ival in symbol table,
! ival double precision integer
character(len=*) :: sym
integer(ki8) :: ival
complex(kc8) :: vald
vald=cmplx(real(ival,kr8),0.0_kr8,kc8)
call valdef_dc(sym,vald)
end subroutine valdef_di
!**********************************************************************
SUBROUTINE VALDEF_SI(sym,ival) ! Associates sym with ival in symbol table,
! ival single precision integer
character(len=*) :: sym
integer(ki4) :: ival
complex(kc8) :: vald
vald=cmplx(real(ival,kr8),0.0,kc8)
call valdef_dc(sym,vald)
end subroutine valdef_si
!**********************************************************************
SUBROUTINE STRDEF(sym,expr) ! Associates sym with the value of the
! expression expr
character(len=*) :: sym,expr
complex(kc8) :: val
if(nparams == 0) then ! Initialize symbol table
params(1)%symbol='PI'
params(1)%value=(3.14159265358979_kr8,0.0_kr8)
params(2)%symbol='I'
params(2)%value=(0.0_kr8,1.0_kr8)
nparams=2
end if
call evalexpr_dc(expr,val) ! val is value of expression expr
if(ierr==0 .or. ierr==9) then
call valdef_dc(sym,val) ! Assign val to symbol sym
end if
end subroutine strdef
!**********************************************************************
SUBROUTINE VALUEP(xinchar,cval) ! Finds double precision complex value
! corresponding to number string xinchar
! or value in symbol table corresponding
! to symbol name xinchar.
character (len=*):: xinchar
complex(kc8) :: cval
real(kr8) :: rval
ierr=0
if(is_letter(xinchar(1:1)).eqv..true.) then ! xinchar is a symbol
call getparam(xinchar,cval)
else ! xinchar is a number string
call value(xinchar,rval,ios) ! rval is the value of xinchar
if(ios > 0) then
ierr=3
write(*,*) 'Error: number string ',trim(xinchar),' does not correspond to a valid number'
write(*,*)
end if
cval=cmplx(rval,0.0_kr8,kc8)
return
end if
end subroutine valuep
!**********************************************************************
SUBROUTINE PUSHOP(op) ! Puts an operator on operator stack
type(item):: op
itop=itop+1
if(itop > numtok) then
write(*,*) 'Error: operator stack overflow in evaluation of expression'
write(*,*)
return
end if
opstack(itop)=op
end subroutine pushop
SUBROUTINE POPOP(op) ! Takes top operator of operator stack and assigns it to op
type(item):: op
op=opstack(itop)
itop=itop-1
end subroutine popop
SUBROUTINE PUSHVAL(val) ! Puts value on value stack
complex(kc8) :: val
itop=itop+1
if(itop > numtok) then
write(*,*) 'Error: value stack overflow in evaluation of expression'
write(*,*)
return
end if
valstack(itop)=val
end subroutine pushval
SUBROUTINE POPVAL(val) ! Takes top value off value stack and assigns it to val
complex(kc8) :: val
val=valstack(itop)
itop=itop-1
end subroutine popval
!**********************************************************************
SUBROUTINE GETPARAM_DC(sym,var) ! Find double precision complex value var
! corresponding to symbol sym
character(len=*) :: sym
character(len=len_trim(sym)) :: usym
complex(kc8) :: var
ierr=0
sym=adjustl(sym)
if(is_letter(sym(1:1)).eqv..false. .or. len_trim(sym)>24) then
ierr=11
write(*,*) 'Error: symbol ',trim(sym),' has incorrect format'
write(*,*)
return
end if
ifind=0
usym=uppercase(sym)
do j=1,nparams
if(trim(usym) == trim(params(j)%symbol)) then
var=params(j)%value
ifind=j
exit
end if
end do
if(ifind == 0) then
ierr=4
write(*,*) 'Error: symbol ',trim(sym), ' not in symbol table'
write(*,*)
return
end if
end subroutine getparam_dc
!**********************************************************************
SUBROUTINE GETPARAM_SC(sym,var) ! Find single precision complex value var
! corresponding to symbol sym
character(len=*) :: sym
complex(kc4) :: var
complex(kc8) :: vard
call getparam_dc(sym,vard)
var=vard
end subroutine getparam_sc
!**********************************************************************
SUBROUTINE GETPARAM_DR(sym,var) ! Find double precision real value var
! corresponding to symbol sym
character(len=*) :: sym
real(kr8) :: var
complex(kc8) :: vard
call getparam_dc(sym,vard)
var=real(vard,kr8)
end subroutine getparam_dr
!**********************************************************************
SUBROUTINE GETPARAM_SR(sym,var) ! Find single precision real value var
! corresponding to symbol sym
character(len=*) :: sym
real(kr4) :: var
complex(kc8) :: vard
call getparam_dc(sym,vard)
var=real(vard)
end subroutine getparam_sr
!**********************************************************************
SUBROUTINE GETPARAM_DI(sym,ivar) ! Find double precision integer value ivar
! corresponding to symbol sym
character(len=*) :: sym
integer(ki8) :: ivar
complex(kc8) :: vard
call getparam_dc(sym,vard)
ivar=nint(real(vard,kr8),ki8)
end subroutine getparam_di
!**********************************************************************
SUBROUTINE GETPARAM_SI(sym,ivar) ! Find single precision integer value ivar
! corresponding to symbol sym
character(len=*) :: sym
integer(ki4) :: ivar
complex(kc8) :: vard
call getparam_dc(sym,vard)
ivar=nint(real(vard,kr8),ki4)
end subroutine getparam_si
!**********************************************************************
SUBROUTINE EVALEQN(eqn) ! Evaluate an equation
character(len=*) :: eqn
character(len=len(eqn)) :: args(2)
complex(kc8) :: val
call parse(eqn,'=',args,nargs) ! Seperate right- and left-hand-sides
call defparam(adjustl(args(1)),args(2)) ! Evaluate right-hand-side and
! assign to symbol on the
! left-hand-side.
end subroutine evaleqn
!**********************************************************************
SUBROUTINE LISTVAR ! List all variables and their values
write(*,'(/a)') ' VARIABLE LIST:'
if(nparams == 0) then ! Initialize symbol table
params(1)%symbol='PI'
params(1)%value=(3.14159265358979_kr8,0.0_kr8)
params(2)%symbol='I'
params(2)%value=(0.0_kr8,1.0_kr8)
nparams=2
end if
do i=1,nparams
write(*,*) trim(params(i)%symbol),' = ',params(i)%value
end do
end subroutine listvar
!**********************************************************************
end module evaluate

/tags/1.0/goodies/extract.f
0,0 → 1,724
PROGRAM extract
c ***********************************************************************
c * Extract columns of a trajectory file *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of parameters
c ----------------------------------------------------------------------
c Numerical epsilon
real eps
parameter (eps=0.0001)
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Extraction mode
character*80 mode
c Input and output format for trajectories (see iotra.f)
character*80 inpfile ! Input filename
character*80 outfile ! Output filename
c Trajectories
integer ntra_inp ! Number of trajectories
integer ntim_inp ! Number of times
integer ncol_inp ! Number of columns
real,allocatable, dimension (:,:,:) :: tra_inp ! Trajectories (ntra,ntim,ncol)
character*80 vars_inp(100) ! Variable names
integer ntra_out ! Number of trajectories
integer ntim_out ! Number of times
integer ncol_out ! Number of columns
real,allocatable, dimension (:,:,:) :: tra_out ! Trajectories (ntra,ntim,ncol)
integer,allocatable, dimension (:) :: ind ! Index for selection
integer,allocatable, dimension (:) :: isok ! Index for selection
character*80 vars_out(100) ! Variable names
real time_inp(500) ! Times of input trajectory
real time_out(500) ! Times of output trajectory
integer refdate(6) ! Reference date
integer ind_time(500) ! Index for time selection
c Auxiliary variables
integer inpmode
integer outmode
integer stat
integer fid
integer i,j,k,n,j0,j1
character*80 str
character*80 split_str(100)
integer split_n
integer isstr,nvars,ileft,iright
character*80 vars(100)
character ch
real tmp0,tmp1
integer ind1
character*2000 linestr
integer istr(100)
integer nstr
character*80 strsplit(100)
integer flag
c ----------------------------------------------------------------------
c Read and handle parameters
c ----------------------------------------------------------------------
c Read parameters
open(10,file='extract.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) mode
read(10,*) ntra_inp,ntim_inp,ncol_inp
read(10,*) str
close(10)
c Split the input string
isstr = 0
split_n = 0
do i=1,80
ch = str(i:i)
if ( (isstr.eq.0).and.(ch.ne.' ') ) then
isstr=1
ileft=i
elseif ( (isstr.eq.1).and.(ch.eq.' ') ) then
isstr = 0
iright = i-1
split_n = split_n+1
split_str(split_n) = str(ileft:iright)
endif
enddo
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,outfile)
if ( (mode.ne.'-startf').and.(outmode.eq.-1) ) then
outmode=1
endif
c ----------------------------------------------------------------------
c Read input trajectories
c ----------------------------------------------------------------------
c Allocate memory
allocate(tra_inp(ntra_inp,ntim_inp,ncol_inp),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_inp ***'
allocate(ind(ntra_inp),stat=stat)
if (stat.ne.0) print*,'*** error allocating array ind ***'
allocate(isok(ntra_inp),stat=stat)
if (stat.ne.0) print*,'*** error allocating array isok ***'
c Read inpufile
fid = 10
call ropen_tra(fid,inpfile,ntra_inp,ntim_inp,ncol_inp,
> refdate,vars_inp,inpmode)
call read_tra (fid,tra_inp,ntra_inp,ntim_inp,ncol_inp,inpmode)
call close_tra(fid,inpmode)
c Check format
if ( vars_inp(1).ne.'time') goto 990
if ( (vars_inp(2).ne.'lon').and.(vars_inp(2).ne.'xpos') ) goto 990
if ( (vars_inp(3).ne.'lat').and.(vars_inp(3).ne.'ypos') ) goto 990
if ( (vars_inp(4).ne.'p' ).and.(vars_inp(4).ne.'ppos') ) goto 990
c ----------------------------------------------------------------------
c Option -vars : Extract columns of variables
c ----------------------------------------------------------------------
if ( mode.ne.'-var' ) goto 100
c Set the first for columns of the output
ncol_out = 4
vars_out(1)='time'
vars_out(2)='lon'
vars_out(3)='lat'
vars_out(4)='p'
ind(1) =1
ind(2) =2
ind(3) =3
ind(4) =4
c Get final list of extraction columns (set number of columns)
do i=1,split_n
if (split_str(i).eq.'to') then
do j=1,ncol_inp
if ( vars_inp(j).eq.split_str(i-1) ) j0 = j + 1
enddo
do j=1,ncol_inp
if ( vars_inp(j).eq.split_str(i+1) ) j1 = j - 1
enddo
do j=j0,j1
ncol_out = ncol_out + 1
vars_out(ncol_out) = vars_inp(j)
enddo
else
ncol_out = ncol_out + 1
vars_out(ncol_out) = split_str(i)
endif
enddo
c Set the dimensions of the output trajectory
ntra_out = ntra_inp
ntim_out = ntim_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Extract <time,lon,lat,p> columns
do i=1,ntra_out
do j=1,ntim_out
tra_out(i,j,1) = tra_inp(i,j,1)
tra_out(i,j,2) = tra_inp(i,j,2)
tra_out(i,j,3) = tra_inp(i,j,3)
tra_out(i,j,4) = tra_inp(i,j,4)
enddo
enddo
c Get indices for new columns (1..4 are already ok)
do i=5,ncol_out
ind(i)=0
enddo
do i=5,ncol_out
do j=1,ncol_inp
if ( vars_inp(j).eq.vars_out(i) ) ind(i) = j
enddo
enddo
c Check if all selected columns are available
do i=1,ncol_out
if ( ind(i).eq.0 ) then
print*,'Invalid column in ',trim(str)
stop
endif
enddo
c Extract the column
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
tra_out(i,j,k) = tra_inp(i,j,ind(k))
enddo
enddo
enddo
100 continue
c ----------------------------------------------------------------------
c Option -times : Extract times of trajectories
c ----------------------------------------------------------------------
if ( mode.ne.'-time' ) goto 110
c Set the dimension of the output trajectory
ntim_out = 0
c Get the list of times for the input trajectory
do i=1,ntim_inp
time_inp(i) = tra_inp(1,i,1)
enddo
c Get final list of extraction times (set number of times)
do i=1,split_n
if (split_str(i).eq.'to') then
read(split_str(i-1),*) tmp0
do j=1,ntim_inp
if ( time_inp(j).eq.tmp0 ) j0 = j + 1
enddo
read(split_str(i+1),*) tmp0
do j=1,ntim_inp
if ( time_inp(j).eq.tmp0 ) j1 = j - 1
enddo
do j=j0,j1
ntim_out = ntim_out + 1
time_out(ntim_out) = time_inp(j)
enddo
elseif (split_str(i).eq.'first') then
ntim_out = ntim_out + 1
time_out(ntim_out) = time_inp(1)
elseif (split_str(i).eq.'last') then
ntim_out = ntim_out + 1
time_out(ntim_out) = time_inp(ntim_inp)
else
ntim_out = ntim_out + 1
read(split_str(i),*) tmp0
time_out(ntim_out) = tmp0
endif
enddo
c Get the indices of the selected times
do i=1,ntim_out
ind_time(i) = 0
enddo
do i=1,ntim_out
do j=1,ntim_inp
if ( abs(time_out(i)-time_inp(j)).lt.eps) ind_time(i) = j
enddo
enddo
do i=1,ntim_out
if ( ind_time(i).eq.0) then
print*,' Invalid time ',time_out(i)
stop
endif
enddo
c Set dimensions of output trajectory
ntra_out = ntra_inp
ncol_out = ncol_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
tra_out(i,j,k) = tra_inp(i,ind_time(j),k)
enddo
enddo
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
110 continue
c ----------------------------------------------------------------------
c Option -tra : Extract trajectories by number
c ----------------------------------------------------------------------
if ( mode.ne.'-tra' ) goto 120
c Set the dimension of the output trajectory
ntra_out = 0
c Get final list of extraction times (set number of times)
do i=1,split_n
if (split_str(i).eq.'to') then
read(split_str(i-1),*) tmp0
read(split_str(i+1),*) tmp1
do j=nint(tmp0)+1,nint(tmp1)-1
ntra_out = ntra_out + 1
ind(ntra_out) = j
enddo
elseif (split_str(i).eq.'first') then
ntra_out = ntra_out + 1
ind(ntra_out) = 1
elseif (split_str(i).eq.'last') then
ntra_out = ntra_out + 1
ind(ntra_out) = ntra_inp
else
ntra_out = ntra_out + 1
read(split_str(i),*) tmp0
ind(ntra_out) = nint(tmp0)
endif
enddo
c Check whether selected trajectories are ok
do i=1,ntra_out
if ( (ind(i).lt.1).or.(ind(i).gt.ntra_inp) ) then
print*,'Invalid trajectory selected ',ind(i)
stop
endif
enddo
c Set dimensions of output trajectory
ntim_out = ntim_inp
ncol_out = ncol_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
tra_out(i,j,k) = tra_inp(ind(i),j,k)
enddo
enddo
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
120 continue
c ----------------------------------------------------------------------
c Option -startf : Extract starting positions for the trajectory file
c ----------------------------------------------------------------------
if ( mode.ne.'-startf' ) goto 130
c Set the first for columns of the output
ncol_out = 4
vars_out(1)='time'
vars_out(2)='lon'
vars_out(3)='lat'
vars_out(4)='p'
ind(1) =1
ind(2) =2
ind(3) =3
ind(4) =4
c Set dimensions of output trajectory
ntim_out = 1
ntra_out = ntra_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
do i=1,ntra_out
do k=1,ncol_out
tra_out(i,1,k) = tra_inp(i,1,k)
enddo
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
130 continue
c ----------------------------------------------------------------------
c Option -index : Extract trajectories by index file
c ----------------------------------------------------------------------
if ( mode.ne.'-index' ) goto 140
c Read the index file
open(10,file=str)
ntra_out = 1
142 read(10,*,end=141) ind(ntra_out)
ntra_out = ntra_out + 1
goto 142
141 continue
ntra_out = ntra_out - 1
close(10)
c Check whether selected trajectories are ok
do i=1,ntra_out
if ( (ind(i).lt.1).or.(ind(i).gt.ntra_inp) ) then
print*,'Invalid trajectory selected ',ind(i)
stop
endif
enddo
c Set dimensions of output trajectory
ntim_out = ntim_inp
ncol_out = ncol_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
tra_out(i,j,k) = tra_inp(ind(i),j,k)
enddo
enddo
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
140 continue
c ----------------------------------------------------------------------
c Option -boolean : Extract trajectories by boolean file
c ----------------------------------------------------------------------
if ( mode.ne.'-boolean' ) goto 150
c Read the index file
open(10,file=str)
ntra_out = 0
do i=1,ntra_inp
read(10,*) ind1
if ( ind1.eq.1 ) then
ntra_out = ntra_out + 1
ind(ntra_out) = i
endif
enddo
close(10)
c Check whether selected trajectories are ok
do i=1,ntra_out
if ( (ind(i).lt.1).or.(ind(i).gt.ntra_inp) ) then
print*,'Invalid trajectory selected ',ind(i)
stop
endif
enddo
c Set dimensions of output trajectory
ntim_out = ntim_inp
ncol_out = ncol_inp
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
tra_out(i,j,k) = tra_inp(ind(i),j,k)
enddo
enddo
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
150 continue
c ----------------------------------------------------------------------
c Option -pattern : Extract trajectories which match a regular expression
c ----------------------------------------------------------------------
if ( mode.ne.'-pattern' ) goto 160
c All times and columns are extracted
ncol_out = ncol_inp
ntim_out = ntim_inp
ntra_out = 0
c Split the search string
nstr = 0
ileft = 0
iright = 0
do i=1,len_trim(str)
if ( (str(i:i).eq.' ').and.(ileft.eq.0) ) then
ileft = ileft + 1
elseif ( (str(i:i).ne.' ').and.(ileft.eq.0) ) then
ileft = i
iright = 0
elseif ( (str(i:i).ne.' ').and.(ileft.ne.0) ) then
iright = i
elseif ( (str(i:i).eq.' ').and.(ileft.ne.0) ) then
nstr = nstr + 1
strsplit(nstr) = str(ileft:iright)
ileft = 0
iright = 0
endif
enddo
if ( (ileft.ne.0).and.(iright.ne.0) ) then
nstr = nstr + 1
strsplit(nstr) = str(ileft:iright)
ileft = 0
endif
c Loop over the trajectories - check for matching pattern
do n=1,ntra_inp
ind(n) = 0
do i=1,ntim_inp
write(linestr,'(1f7.2,f9.2,f8.2,i6,100f10.3)')
> (tra_inp(n,i,j),j=1,3), ! time, lon, lat
> nint(tra_inp(n,i,4)), ! p
> (tra_inp(n,i,j),j=5,ncol_inp) ! fields
flag = 1
do k=1,nstr
istr(k) = index(trim(linestr),trim(strsplit(k)))
if ( istr(k).eq.0 ) flag = 0
enddo
if ( flag.eq.1 ) ind(n) = 1
enddo
if ( ind(n).eq.1 ) ntra_out = ntra_out + 1
enddo
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected times to the output trajectory
ntra_out = 0
do i=1,ntra_inp
if (ind(i).eq.1) then
ntra_out = ntra_out + 1
do j=1,ntim_out
do k=1,ncol_out
tra_out(ntra_out,j,k) = tra_inp(i,j,k)
enddo
enddo
endif
enddo
c Copy meta information
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
160 continue
c ----------------------------------------------------------------------
c Option -leaving : Extract all trajectories which leave domain
c ----------------------------------------------------------------------
if ( mode.ne.'-leaving' ) goto 170
c Set dimensions of output trajectory
ntim_out = ntim_inp
ncol_out = ncol_inp
ntra_out = 0
c Copy the meta data
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
c Determine the number of trajectories leaving domain
do i=1,ntra_inp
isok(i) = 1
do j=1,ntim_inp
if ( tra_inp(i,j,4).lt.0. ) isok(i) = 0
enddo
if ( isok(i).eq.0 ) then
ntra_out = ntra_out + 1
endif
enddo
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected trajectories to the output trajectory
ntra_out = 0
do i=1,ntra_inp
if ( isok(i).eq.0 ) then
ntra_out = ntra_out + 1
do j=1,ntim_inp
do k=1,ncol_out
tra_out(ntra_out,j,k) = tra_inp(i,j,k)
enddo
enddo
endif
enddo
c Copy meta information
170 continue
c ----------------------------------------------------------------------
c Option -staying : Extract all trajectories which stay in domain
c ----------------------------------------------------------------------
if ( mode.ne.'-staying' ) goto 180
c Set dimensions of output trajectory
ntim_out = ntim_inp
ncol_out = ncol_inp
ntra_out = 0
c Copy the meta data
do i=1,ncol_out
vars_out(i) = vars_inp(i)
enddo
c Determine the number of trajectories staying in domain
do i=1,ntra_inp
isok(i) = 1
do j=1,ntim_inp
if ( tra_inp(i,j,4).lt.0. ) isok(i) = 0
enddo
if ( isok(i).eq.1 ) then
ntra_out = ntra_out + 1
endif
enddo
c Allocate memory for output trajectory
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Copy the selected trajectories to the output trajectory
ntra_out = 0
do i=1,ntra_inp
if ( isok(i).eq.1 ) then
ntra_out = ntra_out + 1
do j=1,ntim_inp
do k=1,ncol_out
tra_out(ntra_out,j,k) = tra_inp(i,j,k)
enddo
enddo
endif
enddo
c Copy meta information
180 continue
c ----------------------------------------------------------------------
c Write output trajectories
c ----------------------------------------------------------------------
c Write output as trajectory file
if (outmode.ge.1) then
call wopen_tra(fid,outfile,ntra_out,ntim_out,ncol_out,
> refdate,vars_out,outmode)
call write_tra(fid,tra_out,ntra_out,ntim_out,ncol_out,outmode)
call close_tra(fid,outmode)
c Write output as (lon, lat, p)-list
else
open(10,file=outfile)
do i=1,ntra_out
write(10,'(3f10.2)') tra_out(i,1,2), ! lon
> tra_out(i,1,3), ! lat
> tra_out(i,1,4) ! p
enddo
close(10)
endif
!c ----------------------------------------------------------------------
c Error handling
c ----------------------------------------------------------------------
stop
990 print*,'First columns must be <time,lon,lat,p>... Stop'
stop
end

/tags/1.0/goodies/extract.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = extract.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
extract: $(OBJS)
${F77} -o extract $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/extract.sh
0,0 → 1,67
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp extract short
echo
exit 0
endif
# Set the input and output filenames
set inpfile = $1
set outfile = $2
shift; shift;
# Handle optional arguments (get a list, remove , and / separators)
set mode=$1
shift;
set str=
while ( $#argv > 0 )
set str = "${str} $1"
shift
end
set str=`echo $str | sed -e "s/,//g"`
set str=`echo $str | sed -e "s/\///g"`
# Check that the mode is valid
if ( "${mode}" == "-var" ) goto next
if ( "${mode}" == "-time" ) goto next
if ( "${mode}" == "-tra" ) goto next
if ( "${mode}" == "-startf" ) goto next
if ( "${mode}" == "-index" ) goto next
if ( "${mode}" == "-boolean" ) goto next
if ( "${mode}" == "-pattern" ) goto next
if ( "${mode}" == "-leaving" ) goto next
if ( "${mode}" == "-staying" ) goto next
echo " Invalid mode ${mode}..."
exit 1
next:
# Set program names
set prog1=${LAGRANTO}/goodies/extract
set prog2=${LAGRANTO}/goodies/trainfo.sh
# Get trajectory dimensions
set dim=`${prog2} ${inpfile} dim`
# Run program
\rm -f extract.param
echo \"${inpfile}\" >! extract.param
echo \"${outfile}\" >> extract.param
echo \"${mode}\" >> extract.param
echo ${dim} >> extract.param
echo \"${str}\" >> extract.param
${prog1}
#\rm -f extract.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/gettidiff.f
0,0 → 1,139
program gettidiff
C =================
implicit none
integer idate(5),irefdat(5)
real ihdiff
integer iargc
character*(80) arg
integer nc1,nc2,flag1,flag2
c check for sufficient requested arguments
if (iargc().ne.2) then
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
c read and transform input
call getarg(1,arg)
call lenchar(arg,nc1)
call checkchar(arg,'_',flag1)
if (flag1.eq.7) then
read(arg(1:2),'(i2)',err=120)idate(1)
read(arg(3:4),'(i2)',err=120)idate(2)
read(arg(5:6),'(i2)',err=120)idate(3)
read(arg(8:9),'(i2)',err=120)idate(4)
if (nc1.eq.11) then
read(arg(10:11),'(i2)',err=120)idate(5)
else if (nc1.ne.9) then
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
else if (flag1.eq.9) then
read(arg(1:4),'(i4)',err=120)idate(1)
read(arg(5:6),'(i2)',err=120)idate(2)
read(arg(7:8),'(i2)',err=120)idate(3)
read(arg(10:11),'(i2)',err=120)idate(4)
if (nc1.eq.13) then
read(arg(12:13),'(i2)',err=120)idate(5)
else if (nc1.ne.11) then
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
else
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
call getarg(2,arg)
call lenchar(arg,nc2)
call checkchar(arg,'_',flag2)
if (flag1.ne.flag2) then
print*,
> 'error: both dates must be in same format (YY)YYMMDD_HH(MM)'
call exit(1)
endif
if (flag2.eq.7) then
read(arg(1:2),'(i2)',err=120)irefdat(1)
read(arg(3:4),'(i2)',err=120)irefdat(2)
read(arg(5:6),'(i2)',err=120)irefdat(3)
read(arg(8:9),'(i2)',err=120)irefdat(4)
if (nc2.eq.11) then
read(arg(10:11),'(i2)',err=120)irefdat(5)
else if (nc2.ne.9) then
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
else if (flag2.eq.9) then
read(arg(1:4),'(i4)',err=120)irefdat(1)
read(arg(5:6),'(i2)',err=120)irefdat(2)
read(arg(7:8),'(i2)',err=120)irefdat(3)
read(arg(10:11),'(i2)',err=120)irefdat(4)
if (nc2.eq.13) then
read(arg(12:13),'(i2)',err=120)irefdat(5)
else if (nc2.ne.11) then
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
else
print*,
> 'USAGE: gettidiff date1 date2 (format (YY)YYMMDD_HH(MM))'
call exit(1)
endif
call timediff(idate,irefdat,ihdiff)
if (int(100.*ihdiff).eq.100*int(ihdiff)) then
write(*,*)int(ihdiff)
else
write(*,'(f7.2)')ihdiff
endif
goto 200
120 write(*,*)
>"*** error: date must be in format (YY)YYMMDD_HH(MM) ***"
200 continue
end
subroutine lenchar(string,lstr)
C ===============================
character*(*) string
integer n,lstr
do n=1,len(string)
if (string(n:n).eq."") then
lstr=n-1
goto 100
endif
enddo
100 continue
end
subroutine checkchar(string,char,flag)
C ======================================
character*(*) string
character*(1) char
integer n,flag
flag=0
do n=1,len(string)
if (string(n:n).eq.char) then
flag=n
return
endif
enddo
end

/tags/1.0/goodies/gettidiff.make
0,0 → 1,10
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = gettidiff.o ${LAGRANTO}/lib/times.a
LIBS =
.f.o: $*.f $(INCS)
${F77} -c ${FFLAGS} $*.f
gettidiff: $(OBJS)
${F77} -o gettidiff $(OBJS) $(LIBS)

/tags/1.0/goodies/gettidiff.sh
0,0 → 1,17
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp gettidiff short
echo
exit 0
endif
${LAGRANTO}/goodies/gettidiff $*
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/getvars.f
0,0 → 1,44
C ********************************************************************
program getvarnames
C ********************************************************************
implicit none
include 'netcdf.inc'
integer ndims,nvars,ngatts,recdim,ierr
integer vartyp,ndim,nvatts,vardim(4)
integer cdfid,i
character*80 cdfname
character*20 vnam(100)
integer iargc
character*(80) arg
c check for sufficient requested arguments
if (iargc().ne.1) then
print*,'USAGE: getvars NetCDF-filename'
call exit(1)
endif
c read and transform input
call getarg(1,arg)
cdfname=trim(arg)
call cdfopn(cdfname,cdfid,ierr)
call getvars(cdfid,nvars,vnam,ierr)
C Write variable names to output
do i=1,nvars
write(*,*)vnam(i)
enddo
C Close the files
call clscdf(cdfid,ierr)
end

/tags/1.0/goodies/getvars.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = getvars.o ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
getvars: $(OBJS)
${F77} -o getvars $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/getvars.sh
0,0 → 1,17
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp getvars short
echo
exit 0
endif
${LAGRANTO}/goodies/getvars $*
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/list2lsl.f
0,0 → 1,81
PROGRAM list2lsl
c ***********************************************************************
c * Convert a lat/lon/p list to a trajectory file *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Input and output format for trajectories (see iotra.f)
character*80 inpfile ! Input filename
character*80 outfile ! Output filename
c Trajectories
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
real,allocatable, dimension (:,:,:) :: tra ! Trajectories (ntra,ntim,ncol)
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
real timevalue ! Time
c Auxiliary variables
integer inpmode
integer outmode
integer stat
integer fid
integer i
c ----------------------------------------------------------------------
c Do the reformating
c ----------------------------------------------------------------------
c Read parameters
open(10,file='list2lsl.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) ntra
read(10,*) (refdate(i),i=1,6)
read(10,*) timevalue
close(10)
c Determine the formats
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c Set parameters for output file
ntim=1
ncol=4
vars(1)='time'
vars(2)='lon'
vars(3)='lat'
vars(4)='p'
c Allocate memory
allocate(tra(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra ***'
c Read inpufile
fid = 10
open(fid,file=inpfile)
do i=1,ntra
tra(i,1,1) = timevalue
read(fid,*) tra(i,1,2),tra(i,1,3),tra(i,1,4)
enddo
close(fid)
c Write output file
call wopen_tra(fid,outfile,ntra,ntim,ncol,refdate,vars,outmode)
call write_tra(fid,tra,ntra,ntim,ncol,outmode)
call close_tra(fid,outmode)
end

/tags/1.0/goodies/list2lsl.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = list2lsl.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
list2lsl: $(OBJS)
${F77} -o list2lsl $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/list2lsl.sh
0,0 → 1,61
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp list2lsl short
echo
exit 0
endif
set inpfile=$1
set outfile=$2
set refdate = `date +'%Y%m%d_%H%M'`
set timevalue = 0
while ( $#argv > 0 )
switch ( $argv[1] )
case -ref
set refdate=$argv[2]
shift;
breaksw
case -time
set timevalue=$argv[2]
shift;
breaksw
endsw
shift;
end
set ntra=`wc -l ${inpfile} | awk '{print $1}'`
# Split the reference date
set yyyy=`echo ${refdate} | cut -c 1-4`
set mm=`echo ${refdate} | cut -c 5-6`
set dd=`echo ${refdate} | cut -c 7-8`
set hh=`echo ${refdate} | cut -c 10-11`
set min=`echo ${refdate}00 | cut -c 12-13`
\rm -f list2lsl.param
echo \"${inpfile}\" >! list2lsl.param
echo \"${outfile}\" >> list2lsl.param
echo ${ntra} >> list2lsl.param
echo ${yyyy} ${mm} ${dd} ${hh} ${min} 00 >> list2lsl.param
echo ${timevalue} >> list2lsl.param
${LAGRANTO}/goodies/list2lsl
\rm -f list2lsl.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/lsl2list.f
0,0 → 1,71
PROGRAM lsl2list
c ***********************************************************************
c * Convert a trajectory file into a lat/lon/p list *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Input and output format for trajectories (see iotra.f)
character*80 inpfile ! Input filename
character*80 outfile ! Output filename
c Trajectories
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
real,allocatable, dimension (:,:,:) :: tra ! Trajectories (ntra,ntim,ncol)
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
c Auxiliary variables
integer inpmode
integer stat
integer fid
integer i,j
c ----------------------------------------------------------------------
c Do the reformating
c ----------------------------------------------------------------------
c Read parameters
open(10,file='lsl2list.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) ntra,ntim,ncol
close(10)
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
c Allocate memory
allocate(tra(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra ***'
c Read inpufile
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,tra,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Write output file inpufile
fid = 10
open(fid,file=outfile)
do i=1,ntra
do j=1,ntim
write(fid,'(f9.2,f8.2,i6)')
> tra(i,j,2),tra(i,j,3),nint(tra(i,j,4))
enddo
enddo
close(fid)
end

/tags/1.0/goodies/lsl2list.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = lsl2list.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
lsl2list: $(OBJS)
${F77} -o lsl2list $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/lsl2list.sh
0,0 → 1,31
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp lsl2list short
echo
exit 0
endif
set inpfile=$1
set outfile=$2
set prog1=${LAGRANTO}/goodies/lsl2list
set dim=`${LAGRANTO}/goodies/trainfo.sh ${inpfile} dim`
\rm -f lsl2list.param
echo \"${inpfile}\" >! lsl2list.param
echo \"${outfile}\" >> lsl2list.param
echo ${dim} >> lsl2list.param
${prog1}
#\rm -f lsl2list.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/mergetra.f
0,0 → 1,433
PROGRAM mege
c ***********************************************************************
c * Merge two trajectory files *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of parameters
c ----------------------------------------------------------------------
c Numerical epsilon
real eps
parameter (eps=0.0001)
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Merging mode
integer mode
character*20 datecheck
c Input and output format for trajectories (see iotra.f)
character*80 inpfile1 ! Input filename 1
character*80 inpfile2 ! Input filename 2
character*80 outfile ! Output filename
integer inpmode1 ! Input format 1
integer inpmode2 ! Input format 2
integer outmode ! Output format
c Trajectories
integer ntra_inp1 ! Number of trajectories
integer ntim_inp1 ! Number of times
integer ncol_inp1 ! Number of columns
real,allocatable, dimension (:,:,:) :: tra_inp1 ! Trajectories (ntra,ntim,ncol)
character*80 vars_inp1(100) ! Variable names
real time_inp1(500) ! Times of input trajectory
integer refdate1(6) ! Reference date
integer ntra_inp2 ! Number of trajectories
integer ntim_inp2 ! Number of times
integer ncol_inp2 ! Number of columns
real,allocatable, dimension (:,:,:) :: tra_inp2 ! Trajectories (ntra,ntim,ncol)
character*80 vars_inp2(100) ! Variable names
real time_inp2(500) ! Times of input trajectory
integer refdate2(6) ! Reference date
integer ntra_out ! Number of trajectories
integer ntim_out ! Number of times
integer ncol_out ! Number of columns
real,allocatable, dimension (:,:,:) :: tra_out ! Trajectories (ntra,ntim,ncol)
character*80 vars_out(100) ! Variable names
real time_out(500) ! Times of output trajectory
integer refdate(6) ! Reference date
c Auxiliary variables
integer i,j,k
integer ind(200)
integer itr(200)
integer isok
integer stat
integer fid
real rswap
integer iswap
c ----------------------------------------------------------------------
c Read and handle parameters
c ----------------------------------------------------------------------
c Read parameters
open(10,file='mergetra.param')
read(10,*) inpfile1
read(10,*) inpfile2
read(10,*) outfile
read(10,*) ntra_inp1,ntim_inp1,ncol_inp1
read(10,*) ntra_inp2,ntim_inp2,ncol_inp2
read(10,*) datecheck
close(10)
c Determine the formats
call mode_tra(inpmode1,inpfile1)
if (inpmode1.eq.-1) inpmode1=1
call mode_tra(inpmode2,inpfile2)
if (inpmode2.eq.-1) inpmode2=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c ----------------------------------------------------------------------
c Read input trajectories
c ----------------------------------------------------------------------
c Allocate memory
allocate(tra_inp1(ntra_inp1,ntim_inp1,ncol_inp1),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_inp1 ***'
allocate(tra_inp2(ntra_inp2,ntim_inp2,ncol_inp2),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_inp2 ***'
c Read inpufile
call ropen_tra(fid,inpfile1,ntra_inp1,ntim_inp1,ncol_inp1,
> refdate1,vars_inp1,inpmode1)
call read_tra (fid,tra_inp1,ntra_inp1,ntim_inp1,ncol_inp1,
> inpmode1)
call close_tra(fid,inpmode1)
call ropen_tra(fid,inpfile2,ntra_inp2,ntim_inp2,ncol_inp2,
> refdate2,vars_inp2,inpmode2)
call read_tra (fid,tra_inp2,ntra_inp2,ntim_inp2,ncol_inp2,
> inpmode2)
call close_tra(fid,inpmode2)
c Get the times of the trajectories
do i=1,ntim_inp1
time_inp1(i) = tra_inp1(1,i,1)
enddo
do i=1,ntim_inp2
time_inp2(i) = tra_inp2(1,i,1)
enddo
c Check format
if ( vars_inp1(1).ne.'time' ) goto 990
if ( (vars_inp1(2).ne.'lon').and.
> (vars_inp1(2).ne.'xpos') ) goto 990
if ( (vars_inp1(3).ne.'lat').and.
> (vars_inp1(3).ne.'ypos') ) goto 990
if ( (vars_inp1(4).ne.'p' ).and.
> (vars_inp1(4).ne.'ppos') ) goto 990
if ( vars_inp2(1).ne.'time' ) goto 990
if ( (vars_inp2(2).ne.'lon').and.
> (vars_inp2(2).ne.'xpos') ) goto 990
if ( (vars_inp2(3).ne.'lat').and.
> (vars_inp2(3).ne.'ypos') ) goto 990
if ( (vars_inp2(4).ne.'p' ).and.
> (vars_inp2(4).ne.'ppos') ) goto 990
c Check whether the reference dates are equal
if ( datecheck.eq.'datecheck' ) then
do i=1,5
if ( refdate1(i).ne.refdate2(i) ) then
print*,' ERROR; Reference dates must be the same... Stop'
print*,(refdate1(j),j=1,5)
print*,(refdate2(j),j=1,5)
stop
endif
enddo
endif
c ----------------------------------------------------------------------
c Decide what to do
c ----------------------------------------------------------------------
c Init the mode
mode = 0
c ---- Check whether only the columns should be combined (mode 1) -------
print*,'Testing for mode 1 (combine columns)'
if ( ntim_inp1.ne.ntim_inp2 ) goto 100
print*,' -> ntim ok'
if ( ntra_inp1.ne.ntra_inp2 ) goto 100
print*,' -> ntra ok'
do i=1,ntim_inp1
if ( time_inp1(i).ne.time_inp2(i) ) goto 100
enddo
print*,' -> times ok'
do i=1,ntra_inp1
do j=1,ntim_inp1
if ( tra_inp1(i,j,1).ne.tra_inp2(i,j,1) ) goto 100
if ( tra_inp1(i,j,2).ne.tra_inp2(i,j,2) ) goto 100
if ( tra_inp1(i,j,3).ne.tra_inp2(i,j,3) ) goto 100
if ( tra_inp1(i,j,4).ne.tra_inp2(i,j,4) ) goto 100
enddo
enddo
print*,' -> lon,lat,p ok => Mode 1 accepted'
mode = 1
goto 130
100 continue
c ---- Check whether second file to appended to first one (mode 2) -----
print*,'Testing for mode 2 (append file 2 to file 1)'
if ( ntim_inp1.ne.ntim_inp2 ) goto 110
print*,' -> ntim ok'
if ( ncol_inp1.ne.ncol_inp2 ) goto 110
print*,' -> ncol ok'
do i=1,ntim_inp1
if ( time_inp1(i).ne.time_inp2(i) ) goto 110
enddo
print*,' -> times ok'
do i=1,ncol_inp1
if ( vars_inp1(i).ne.vars_inp2(i) ) goto 110
enddo
print*,' -> vars ok => Mode 2 accepted'
mode = 2
goto 130
110 continue
c ----- Check whether to combine different times (mode 3) --------------
print*,'Testing for mode 3 (combining times)'
if ( ntra_inp1.ne.ntra_inp2 ) goto 120
print*,' -> ntra ok'
if ( ncol_inp1.ne.ncol_inp2 ) goto 120
print*,' -> ncol ok'
do i=1,ncol_inp1
if ( vars_inp1(i).ne.vars_inp2(i) ) goto 120
enddo
print*,' -> vars ok => Mode 3 accepted'
mode = 3
goto 130
120 continue
c ----- Stop if no valid merging mode could be determined -------------
print*,' ERROR: could not determine merging mode ...'
stop
c Exit point for mode decision
130 continue
c ----------------------------------------------------------------------
c Merging depending on mode
c ----------------------------------------------------------------------
c ------ Merging of columns (mode 1) -----------------------------------
if ( mode.ne.1 ) goto 200
c Get the complete list of additional field
do i=1,ncol_inp1
ncol_out = ncol_out + 1
vars_out(ncol_out) = vars_inp1(i)
ind(ncol_out) = i
itr(ncol_out) = 1
enddo
do i=5,ncol_inp2
isok=1
do j=1,ncol_out
if ( vars_inp2(i).eq.vars_out(j) ) isok=0
enddo
if ( isok.eq.1 ) then
ncol_out = ncol_out + 1
vars_out(ncol_out) = vars_inp2(i)
ind(ncol_out) = i
itr(ncol_out) = 2
endif
enddo
c Allocate memory for output trajectory
ntra_out = ntra_inp1
ntim_out = ntim_inp1
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Save the trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
if ( itr(k).eq.1) then
tra_out(i,j,k) = tra_inp1(i,j,ind(k))
else
tra_out(i,j,k) = tra_inp2(i,j,ind(k))
endif
enddo
enddo
enddo
200 continue
c ------ Appending files (mode 2) --------------------------------------
if ( mode.ne.2 ) goto 210
c Allocate memory for output trajectory
ntra_out = ntra_inp1 + ntra_inp2
ntim_out = ntim_inp1
ncol_out = ncol_inp1
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Set the field names for the output trajectory
do i=1,ncol_out
vars_out(i) = vars_inp1(i)
enddo
c Save the trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
if ( i.le.ntra_inp1 ) then
tra_out(i,j,k) = tra_inp1(i ,j,k)
else
tra_out(i,j,k) = tra_inp2(i-ntra_inp1,j,k)
endif
enddo
enddo
enddo
210 continue
c ------ Combining times (mode 3) --------------------------------------
if ( mode.ne.3 ) goto 220
c Get a list of all output times
ntim_out = 0
do i=1,ntim_inp1
isok = 1
do j=1,ntim_out
if ( time_inp1(i).eq.time_out(j) ) isok=0
enddo
if (isok.eq.1 ) then
ntim_out = ntim_out + 1
time_out(ntim_out) = time_inp1(i)
itr(ntim_out) = 1
ind(ntim_out) = i
endif
enddo
do i=1,ntim_inp2
isok = 1
do j=1,ntim_out
if ( time_inp2(i).eq.time_out(j) ) isok=0
enddo
if (isok.eq.1 ) then
ntim_out = ntim_out + 1
time_out(ntim_out) = time_inp2(i)
itr(ntim_out) = 2
ind(ntim_out) = i
endif
enddo
c Sort the times
do i=1,ntim_out
do j=i+1,ntim_out
if ( time_out(j).lt.time_out(i) ) then
rswap = time_out(i)
time_out(i) = time_out(j)
time_out(j) = rswap
iswap = itr(i)
itr(i) = itr(j)
itr(j) = iswap
iswap = ind(i)
ind(i) = ind(j)
ind(j) = iswap
endif
enddo
enddo
c Allocate memory for output trajectory
ntra_out = ntra_inp1
ncol_out = ncol_inp1
allocate(tra_out(ntra_out,ntim_out,ncol_out),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra_out ***'
c Set the field names for the output trajectory
do i=1,ncol_out
vars_out(i) = vars_inp1(i)
enddo
c Save the trajectory
do i=1,ntra_out
do j=1,ntim_out
do k=1,ncol_out
if ( itr(j).eq.1 ) then
tra_out(i,j,k) = tra_inp1(i,ind(j),k)
else
tra_out(i,j,k) = tra_inp2(i,ind(j),k)
endif
enddo
enddo
enddo
220 continue
c ----------------------------------------------------------------------
c Write the output trajectory
c ----------------------------------------------------------------------
call wopen_tra(fid,outfile,ntra_out,ntim_out,ncol_out,
> refdate1,vars_out,outmode)
call write_tra(fid,tra_out,ntra_out,ntim_out,ncol_out,outmode)
call close_tra(fid,outmode)
c ----------------------------------------------------------------------
c Error handling
c ----------------------------------------------------------------------
stop
990 print*,'First columns must be <time,lon,lat,p>... Stop'
stop
end

/tags/1.0/goodies/mergetra.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = mergetra.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
mergetra: $(OBJS)
${F77} -o mergetra $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/mergetra.sh
0,0 → 1,52
#!/bin/csh
# -----------------------------------------------------------------------------
# Set some parameters
# -----------------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp mergetra short
echo
exit 0
endif
# Set input file
set inpfile1 = $1
set inpfile2 = $2
set outfile = $3
shift; shift; shift
# Handle optional arguments
set datecheck = "datecheck"
while ( $#argv > 0 )
if ( "$1" == "-nodatecheck" ) set datecheck="nodatecheck"
shift
end
# Set Fortran program
set prog=${LAGRANTO}/goodies/mergetra
# -----------------------------------------------------------------------------
# Run program
# -----------------------------------------------------------------------------
set dims1=`${LAGRANTO}/goodies/trainfo.sh ${inpfile1} dim`
set dims2=`${LAGRANTO}/goodies/trainfo.sh ${inpfile2} dim`
\rm -f mergetra.param
echo \"${inpfile1}\" >! mergetra.param
echo \"${inpfile2}\" >> mergetra.param
echo \"${outfile}\" >> mergetra.param
echo ${dims1} >> mergetra.param
echo ${dims2} >> mergetra.param
echo \"${datecheck}\" >> mergetra.param
${prog}
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/newtime.f
0,0 → 1,129
program calcnewdate
C ===================
implicit none
integer date1(5),date2(5)
integer iargc
real diff
character*(80) arg,yychar,cdat
character*(2) cdate(4)
integer flag,nc
c check for sufficient requested arguments
if (iargc().ne.2) then
print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'
call exit(1)
endif
c read and transform input
call getarg(1,arg)
call lenchar(arg,nc)
if (nc.eq.9) then
yychar=''
read(arg(1:2),'(i2)',err=120)date1(1)
read(arg(3:4),'(i2)',err=120)date1(2)
read(arg(5:6),'(i2)',err=120)date1(3)
read(arg(8:9),'(i2)',err=120)date1(4)
else if (nc.eq.11) then
yychar=arg(1:2)
read(arg(3:4),'(i2)',err=120)date1(1)
read(arg(5:6),'(i2)',err=120)date1(2)
read(arg(7:8),'(i2)',err=120)date1(3)
read(arg(10:11),'(i2)',err=120)date1(4)
else
print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'
call exit(1)
endif
call getarg(2,arg)
call checkchar(arg,".",flag)
if (flag.eq.0) arg=trim(arg)//"."
read(arg,'(f10.2)') diff
call newdate(date1,diff,date2)
c Transition 2000
if ((date2(1).lt.date1(1)).and.
> (diff.gt.0.).and.
> (yychar.eq.'19')) yychar='20'
if (date2(1).lt.0) date2(1)=date2(1)+100
if ((date2(1).gt.date1(1)).and.
> (diff.lt.0.).and.
> (yychar.eq.'20')) yychar='19'
c Transition 1900
if ((date2(1).lt.date1(1)).and.
> (diff.gt.0.).and.
> (yychar.eq.'18')) yychar='19'
if (date2(1).lt.0) date2(1)=date2(1)+100
if ((date2(1).gt.date1(1)).and.
> (diff.lt.0.).and.
> (yychar.eq.'19')) yychar='18'
if (date2(1).lt.10) then
write(cdate(1),'(a,i1)')'0',date2(1)
else
write(cdate(1),'(i2)')date2(1)
endif
if (date2(2).lt.10) then
write(cdate(2),'(a,i1)')'0',date2(2)
else
write(cdate(2),'(i2)')date2(2)
endif
if (date2(3).lt.10) then
write(cdate(3),'(a,i1)')'0',date2(3)
else
write(cdate(3),'(i2)')date2(3)
endif
if (date2(4).lt.10) then
write(cdate(4),'(a,i1)')'0',date2(4)
else
write(cdate(4),'(i2)')date2(4)
endif
cdat=trim(yychar)//cdate(1)//cdate(2)//cdate(3)//'_'//cdate(4)
write(*,'(a)')trim(cdat)
goto 200
120 write(*,*)"*** error: date must be in format (YY)YYMMDD_HH ***"
200 continue
end
subroutine checkchar(string,char,flag)
C ======================================
character*(*) string
character*(1) char
integer n,flag
flag=0
do n=1,len(string)
if (string(n:n).eq.char) then
flag=n
return
endif
enddo
end
subroutine lenchar(string,lstr)
C ===============================
character*(*) string
integer n,lstr
do n=1,len(string)
if (string(n:n).eq."") then
lstr=n-1
goto 100
endif
enddo
100 continue
end

/tags/1.0/goodies/newtime.make
0,0 → 1,10
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = newtime.o ${LAGRANTO}/lib/times.a
LIBS =
.f.o: $*.f $(INCS)
${F77} -c ${FFLAGS} $*.f
newtime: $(OBJS)
${F77} -o newtime $(OBJS) $(LIBS)

/tags/1.0/goodies/newtime.sh
0,0 → 1,17
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp newtime short
echo
exit 0
endif
${LAGRANTO}/goodies/newtime $*
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/precmod.f90
0,0 → 1,18
module precision
! Real kinds
integer, parameter :: kr4 = selected_real_kind(6,37) ! single precision real
integer, parameter :: kr8 = selected_real_kind(15,307) ! double precision real
! Integer kinds
integer, parameter :: ki4 = selected_int_kind(9) ! single precision integer
integer, parameter :: ki8 = selected_int_kind(18) ! double precision integer
!Complex kinds
integer, parameter :: kc4 = kr4 ! single precision complex
integer, parameter :: kc8 = kr8 ! double precision complex
end module precision

/tags/1.0/goodies/reformat.f
0,0 → 1,68
PROGRAM reformat
c ***********************************************************************
c * Change format of a trajectory file *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Input and output format for trajectories (see iotra.f)
character*80 inpfile ! Input filename
character*80 outfile ! Output filename
c Trajectories
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
real,allocatable, dimension (:,:,:) :: tra ! Trajectories (ntra,ntim,ncol)
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
c Auxiliary variables
integer inpmode
integer outmode
integer stat
integer fid
integer i
c ----------------------------------------------------------------------
c Do the reformating
c ----------------------------------------------------------------------
c Read parameters
open(10,file='reformat.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) ntra,ntim,ncol
close(10)
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c Allocate memory
allocate(tra(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra ***'
c Read inpufile
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,tra,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Write output file
call wopen_tra(fid,outfile,ntra,ntim,ncol,refdate,vars,outmode)
call write_tra(fid,tra,ntra,ntim,ncol,outmode)
call close_tra(fid,outmode)
end

/tags/1.0/goodies/reformat.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = reformat.o ${LAGRANTO}/lib//iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
reformat: $(OBJS)
${F77} -o reformat $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/reformat.refprof
0,0 → 1,3007
1976 Standard Atmosphere
1: Altitude[m]
2: Temperature [Kelvin]
3: Pressure [pascal]
0.00000 288.150 101325
10.0000 288.085 101205
20.0000 288.020 101085
30.0000 287.955 100965
40.0000 287.890 100845
50.0000 287.825 100726
60.0000 287.760 100606
70.0000 287.695 100487
80.0000 287.630 100368
90.0000 287.565 100248
100.000 287.500 100129
110.000 287.435 100011
120.000 287.370 99891.7
130.000 287.305 99773.0
140.000 287.240 99654.4
150.000 287.175 99536.0
160.000 287.110 99417.6
170.000 287.045 99299.4
180.000 286.980 99181.2
190.000 286.915 99063.2
200.000 286.850 98945.3
210.000 286.785 98827.5
220.000 286.720 98709.9
230.000 286.655 98592.3
240.000 286.590 98474.9
250.000 286.525 98357.5
260.000 286.460 98240.3
270.000 286.395 98123.2
280.000 286.330 98006.2
290.000 286.265 97889.3
300.000 286.200 97772.6
310.000 286.135 97655.9
320.000 286.070 97539.4
330.000 286.005 97423.0
340.000 285.940 97306.6
350.000 285.875 97190.4
360.000 285.810 97074.3
370.000 285.745 96958.4
380.000 285.680 96842.5
390.000 285.615 96726.8
400.000 285.550 96611.1
410.000 285.485 96495.6
420.000 285.420 96380.2
430.000 285.355 96264.9
440.000 285.290 96149.7
450.000 285.225 96034.6
460.000 285.160 95919.6
470.000 285.095 95804.7
480.000 285.030 95690.0
490.000 284.965 95575.4
500.000 284.900 95460.8
510.000 284.835 95346.4
520.000 284.770 95232.1
530.000 284.705 95117.9
540.000 284.640 95003.8
550.000 284.575 94889.9
560.000 284.510 94776.0
570.000 284.445 94662.3
580.000 284.380 94548.6
590.000 284.315 94435.1
600.000 284.250 94321.7
610.000 284.185 94208.4
620.000 284.120 94095.2
630.000 284.055 93982.1
640.000 283.990 93869.1
650.000 283.925 93756.2
660.000 283.860 93643.5
670.000 283.795 93530.8
680.000 283.730 93418.3
690.000 283.665 93305.9
700.000 283.600 93193.6
710.000 283.535 93081.4
720.000 283.470 92969.3
730.000 283.405 92857.3
740.000 283.340 92745.4
750.000 283.275 92633.6
760.000 283.210 92521.9
770.000 283.145 92410.4
780.000 283.080 92299.0
790.000 283.015 92187.6
800.000 282.950 92076.4
810.000 282.885 91965.3
820.000 282.820 91854.3
830.000 282.755 91743.4
840.000 282.690 91632.6
850.000 282.625 91521.9
860.000 282.560 91411.3
870.000 282.495 91300.8
880.000 282.430 91190.5
890.000 282.365 91080.2
900.000 282.300 90970.1
910.000 282.235 90860.1
920.000 282.170 90750.1
930.000 282.105 90640.3
940.000 282.040 90530.6
950.000 281.975 90421.0
960.000 281.910 90311.5
970.000 281.845 90202.1
980.000 281.780 90092.8
990.000 281.715 89983.6
1000.00 281.650 89874.6
1010.00 281.585 89765.6
1020.00 281.520 89656.8
1030.00 281.455 89548.0
1040.00 281.390 89439.4
1050.00 281.325 89330.8
1060.00 281.260 89222.4
1070.00 281.195 89114.1
1080.00 281.130 89005.9
1090.00 281.065 88897.8
1100.00 281.000 88789.8
1110.00 280.935 88681.9
1120.00 280.870 88574.1
1130.00 280.805 88466.4
1140.00 280.740 88358.8
1150.00 280.675 88251.3
1160.00 280.610 88144.0
1170.00 280.545 88036.7
1180.00 280.480 87929.6
1190.00 280.415 87822.5
1200.00 280.350 87715.6
1210.00 280.285 87608.7
1220.00 280.220 87502.0
1230.00 280.155 87395.4
1240.00 280.090 87288.9
1250.00 280.025 87182.5
1260.00 279.960 87076.1
1270.00 279.895 86969.9
1280.00 279.830 86863.8
1290.00 279.765 86757.8
1300.00 279.700 86651.9
1310.00 279.635 86546.2
1320.00 279.570 86440.5
1330.00 279.505 86334.9
1340.00 279.440 86229.4
1350.00 279.375 86124.1
1360.00 279.310 86018.8
1370.00 279.245 85913.6
1380.00 279.180 85808.6
1390.00 279.115 85703.6
1400.00 279.050 85598.8
1410.00 278.985 85494.0
1420.00 278.920 85389.4
1430.00 278.855 85284.9
1440.00 278.790 85180.4
1450.00 278.725 85076.1
1460.00 278.660 84971.9
1470.00 278.595 84867.8
1480.00 278.530 84763.7
1490.00 278.465 84659.8
1500.00 278.400 84556.0
1510.00 278.335 84452.3
1520.00 278.270 84348.7
1530.00 278.205 84245.2
1540.00 278.140 84141.8
1550.00 278.075 84038.5
1560.00 278.010 83935.3
1570.00 277.945 83832.2
1580.00 277.880 83729.2
1590.00 277.815 83626.3
1600.00 277.750 83523.5
1610.00 277.685 83420.9
1620.00 277.620 83318.3
1630.00 277.555 83215.8
1640.00 277.490 83113.4
1650.00 277.425 83011.1
1660.00 277.360 82909.0
1670.00 277.295 82806.9
1680.00 277.230 82704.9
1690.00 277.165 82603.1
1700.00 277.100 82501.3
1710.00 277.035 82399.6
1720.00 276.970 82298.1
1730.00 276.905 82196.6
1740.00 276.840 82095.3
1750.00 276.775 81994.0
1760.00 276.710 81892.8
1770.00 276.645 81791.8
1780.00 276.580 81690.8
1790.00 276.515 81590.0
1800.00 276.450 81489.2
1810.00 276.385 81388.6
1820.00 276.320 81288.0
1830.00 276.255 81187.6
1840.00 276.190 81087.2
1850.00 276.125 80987.0
1860.00 276.060 80886.8
1870.00 275.995 80786.8
1880.00 275.930 80686.8
1890.00 275.865 80587.0
1900.00 275.800 80487.2
1910.00 275.735 80387.6
1920.00 275.670 80288.0
1930.00 275.605 80188.6
1940.00 275.540 80089.2
1950.00 275.475 79990.0
1960.00 275.410 79890.8
1970.00 275.345 79791.8
1980.00 275.280 79692.8
1990.00 275.215 79594.0
2000.00 275.150 79495.2
2010.00 275.085 79396.6
2020.00 275.020 79298.0
2030.00 274.955 79199.6
2040.00 274.890 79101.2
2050.00 274.825 79002.9
2060.00 274.760 78904.8
2070.00 274.695 78806.7
2080.00 274.630 78708.8
2090.00 274.565 78610.9
2100.00 274.500 78513.1
2110.00 274.435 78415.5
2120.00 274.370 78317.9
2130.00 274.305 78220.4
2140.00 274.240 78123.1
2150.00 274.175 78025.8
2160.00 274.110 77928.6
2170.00 274.045 77831.5
2180.00 273.980 77734.6
2190.00 273.915 77637.7
2200.00 273.850 77540.9
2210.00 273.785 77444.2
2220.00 273.720 77347.6
2230.00 273.655 77251.1
2240.00 273.590 77154.7
2250.00 273.525 77058.5
2260.00 273.460 76962.3
2270.00 273.395 76866.2
2280.00 273.330 76770.2
2290.00 273.265 76674.3
2300.00 273.200 76578.4
2310.00 273.135 76482.7
2320.00 273.070 76387.1
2330.00 273.005 76291.6
2340.00 272.940 76196.2
2350.00 272.875 76100.9
2360.00 272.810 76005.6
2370.00 272.745 75910.5
2380.00 272.680 75815.5
2390.00 272.615 75720.5
2400.00 272.550 75625.7
2410.00 272.485 75530.9
2420.00 272.420 75436.3
2430.00 272.355 75341.7
2440.00 272.290 75247.3
2450.00 272.225 75152.9
2460.00 272.160 75058.6
2470.00 272.095 74964.5
2480.00 272.030 74870.4
2490.00 271.965 74776.4
2500.00 271.900 74682.5
2510.00 271.835 74588.7
2520.00 271.770 74495.1
2530.00 271.705 74401.5
2540.00 271.640 74308.0
2550.00 271.575 74214.5
2560.00 271.510 74121.2
2570.00 271.445 74028.0
2580.00 271.380 73934.9
2590.00 271.315 73841.9
2600.00 271.250 73748.9
2610.00 271.185 73656.1
2620.00 271.120 73563.4
2630.00 271.055 73470.7
2640.00 270.990 73378.2
2650.00 270.925 73285.7
2660.00 270.860 73193.3
2670.00 270.795 73101.1
2680.00 270.730 73008.9
2690.00 270.665 72916.8
2700.00 270.600 72824.8
2710.00 270.535 72732.9
2720.00 270.470 72641.1
2730.00 270.405 72549.4
2740.00 270.340 72457.8
2750.00 270.275 72366.3
2760.00 270.210 72274.9
2770.00 270.145 72183.5
2780.00 270.080 72092.3
2790.00 270.015 72001.1
2800.00 269.950 71910.1
2810.00 269.885 71819.1
2820.00 269.820 71728.3
2830.00 269.755 71637.5
2840.00 269.690 71546.8
2850.00 269.625 71456.2
2860.00 269.560 71365.7
2870.00 269.495 71275.3
2880.00 269.430 71185.0
2890.00 269.365 71094.8
2900.00 269.300 71004.7
2910.00 269.235 70914.7
2920.00 269.170 70824.7
2930.00 269.105 70734.9
2940.00 269.040 70645.1
2950.00 268.975 70555.5
2960.00 268.910 70465.9
2970.00 268.845 70376.4
2980.00 268.780 70287.0
2990.00 268.715 70197.7
3000.00 268.650 70108.5
3010.00 268.585 70019.4
3020.00 268.520 69930.4
3030.00 268.455 69841.5
3040.00 268.390 69752.7
3050.00 268.325 69663.9
3060.00 268.260 69575.3
3070.00 268.195 69486.7
3080.00 268.130 69398.2
3090.00 268.065 69309.9
3100.00 268.000 69221.6
3110.00 267.935 69133.4
3120.00 267.870 69045.3
3130.00 267.805 68957.3
3140.00 267.740 68869.3
3150.00 267.675 68781.5
3160.00 267.610 68693.8
3170.00 267.545 68606.1
3180.00 267.480 68518.6
3190.00 267.415 68431.1
3200.00 267.350 68343.7
3210.00 267.285 68256.4
3220.00 267.220 68169.2
3230.00 267.155 68082.1
3240.00 267.090 67995.1
3250.00 267.025 67908.2
3260.00 266.960 67821.3
3270.00 266.895 67734.6
3280.00 266.830 67647.9
3290.00 266.765 67561.4
3300.00 266.700 67474.9
3310.00 266.635 67388.5
3320.00 266.570 67302.2
3330.00 266.505 67216.0
3340.00 266.440 67129.9
3350.00 266.375 67043.9
3360.00 266.310 66957.9
3370.00 266.245 66872.1
3380.00 266.180 66786.3
3390.00 266.115 66700.6
3400.00 266.050 66615.0
3410.00 265.985 66529.6
3420.00 265.920 66444.1
3430.00 265.855 66358.8
3440.00 265.790 66273.6
3450.00 265.725 66188.5
3460.00 265.660 66103.4
3470.00 265.595 66018.4
3480.00 265.530 65933.6
3490.00 265.465 65848.8
3500.00 265.400 65764.1
3510.00 265.335 65679.5
3520.00 265.270 65595.0
3530.00 265.205 65510.5
3540.00 265.140 65426.2
3550.00 265.075 65341.9
3560.00 265.010 65257.7
3570.00 264.945 65173.7
3580.00 264.880 65089.7
3590.00 264.815 65005.8
3600.00 264.750 64921.9
3610.00 264.685 64838.2
3620.00 264.620 64754.6
3630.00 264.555 64671.0
3640.00 264.490 64587.5
3650.00 264.425 64504.2
3660.00 264.360 64420.9
3670.00 264.295 64337.7
3680.00 264.230 64254.5
3690.00 264.165 64171.5
3700.00 264.100 64088.6
3710.00 264.035 64005.7
3720.00 263.970 63922.9
3730.00 263.905 63840.2
3740.00 263.840 63757.6
3750.00 263.775 63675.1
3760.00 263.710 63592.7
3770.00 263.645 63510.4
3780.00 263.580 63428.1
3790.00 263.515 63345.9
3800.00 263.450 63263.9
3810.00 263.385 63181.9
3820.00 263.320 63100.0
3830.00 263.255 63018.1
3840.00 263.190 62936.4
3850.00 263.125 62854.7
3860.00 263.060 62773.2
3870.00 262.995 62691.7
3880.00 262.930 62610.3
3890.00 262.865 62529.0
3900.00 262.800 62447.8
3910.00 262.735 62366.6
3920.00 262.670 62285.6
3930.00 262.605 62204.6
3940.00 262.540 62123.7
3950.00 262.475 62042.9
3960.00 262.410 61962.2
3970.00 262.345 61881.6
3980.00 262.280 61801.1
3990.00 262.215 61720.6
4000.00 262.150 61640.2
4010.00 262.085 61559.9
4020.00 262.020 61479.7
4030.00 261.955 61399.6
4040.00 261.890 61319.6
4050.00 261.825 61239.6
4060.00 261.760 61159.8
4070.00 261.695 61080.0
4080.00 261.630 61000.3
4090.00 261.565 60920.7
4100.00 261.500 60841.2
4110.00 261.435 60761.7
4120.00 261.370 60682.4
4130.00 261.305 60603.1
4140.00 261.240 60523.9
4150.00 261.175 60444.8
4160.00 261.110 60365.8
4170.00 261.045 60286.8
4180.00 260.980 60208.0
4190.00 260.915 60129.2
4200.00 260.850 60050.5
4210.00 260.785 59971.9
4220.00 260.720 59893.4
4230.00 260.655 59814.9
4240.00 260.590 59736.6
4250.00 260.525 59658.3
4260.00 260.460 59580.1
4270.00 260.395 59502.0
4280.00 260.330 59424.0
4290.00 260.265 59346.1
4300.00 260.200 59268.2
4310.00 260.135 59190.4
4320.00 260.070 59112.7
4330.00 260.005 59035.1
4340.00 259.940 58957.6
4350.00 259.875 58880.1
4360.00 259.810 58802.8
4370.00 259.745 58725.5
4380.00 259.680 58648.3
4390.00 259.615 58571.2
4400.00 259.550 58494.2
4410.00 259.485 58417.2
4420.00 259.420 58340.3
4430.00 259.355 58263.5
4440.00 259.290 58186.8
4450.00 259.225 58110.2
4460.00 259.160 58033.7
4470.00 259.095 57957.2
4480.00 259.030 57880.8
4490.00 258.965 57804.5
4500.00 258.900 57728.3
4510.00 258.835 57652.2
4520.00 258.770 57576.1
4530.00 258.705 57500.2
4540.00 258.640 57424.3
4550.00 258.575 57348.5
4560.00 258.510 57272.7
4570.00 258.445 57197.1
4580.00 258.380 57121.5
4590.00 258.315 57046.0
4600.00 258.250 56970.6
4610.00 258.185 56895.3
4620.00 258.120 56820.1
4630.00 258.055 56744.9
4640.00 257.990 56669.8
4650.00 257.925 56594.8
4660.00 257.860 56519.9
4670.00 257.795 56445.0
4680.00 257.730 56370.3
4690.00 257.665 56295.6
4700.00 257.600 56221.0
4710.00 257.535 56146.5
4720.00 257.470 56072.0
4730.00 257.405 55997.7
4740.00 257.340 55923.4
4750.00 257.275 55849.2
4760.00 257.210 55775.1
4770.00 257.145 55701.0
4780.00 257.080 55627.1
4790.00 257.015 55553.2
4800.00 256.950 55479.4
4810.00 256.885 55405.7
4820.00 256.820 55332.0
4830.00 256.755 55258.5
4840.00 256.690 55185.0
4850.00 256.625 55111.6
4860.00 256.560 55038.2
4870.00 256.495 54965.0
4880.00 256.430 54891.8
4890.00 256.365 54818.7
4900.00 256.300 54745.7
4910.00 256.235 54672.8
4920.00 256.170 54599.9
4930.00 256.105 54527.1
4940.00 256.040 54454.5
4950.00 255.975 54381.8
4960.00 255.910 54309.3
4970.00 255.845 54236.8
4980.00 255.780 54164.4
4990.00 255.715 54092.1
5000.00 255.650 54019.9
5010.00 255.585 53947.8
5020.00 255.520 53875.7
5030.00 255.455 53803.7
5040.00 255.390 53731.8
5050.00 255.325 53659.9
5060.00 255.260 53588.2
5070.00 255.195 53516.5
5080.00 255.130 53444.9
5090.00 255.065 53373.4
5100.00 255.000 53301.9
5110.00 254.935 53230.6
5120.00 254.870 53159.3
5130.00 254.805 53088.0
5140.00 254.740 53016.9
5150.00 254.675 52945.8
5160.00 254.610 52874.9
5170.00 254.545 52803.9
5180.00 254.480 52733.1
5190.00 254.415 52662.4
5200.00 254.350 52591.7
5210.00 254.285 52521.1
5220.00 254.220 52450.6
5230.00 254.155 52380.1
5240.00 254.090 52309.7
5250.00 254.025 52239.4
5260.00 253.960 52169.2
5270.00 253.895 52099.1
5280.00 253.830 52029.0
5290.00 253.765 51959.0
5300.00 253.700 51889.1
5310.00 253.635 51819.3
5320.00 253.570 51749.5
5330.00 253.505 51679.8
5340.00 253.440 51610.2
5350.00 253.375 51540.7
5360.00 253.310 51471.3
5370.00 253.245 51401.9
5380.00 253.180 51332.6
5390.00 253.115 51263.3
5400.00 253.050 51194.2
5410.00 252.985 51125.1
5420.00 252.920 51056.1
5430.00 252.855 50987.2
5440.00 252.790 50918.3
5450.00 252.725 50849.6
5460.00 252.660 50780.9
5470.00 252.595 50712.2
5480.00 252.530 50643.7
5490.00 252.465 50575.2
5500.00 252.400 50506.8
5510.00 252.335 50438.5
5520.00 252.270 50370.2
5530.00 252.205 50302.1
5540.00 252.140 50234.0
5550.00 252.075 50165.9
5560.00 252.010 50098.0
5570.00 251.945 50030.1
5580.00 251.880 49962.3
5590.00 251.815 49894.6
5600.00 251.750 49826.9
5610.00 251.685 49759.3
5620.00 251.620 49691.8
5630.00 251.555 49624.4
5640.00 251.490 49557.0
5650.00 251.425 49489.8
5660.00 251.360 49422.5
5670.00 251.295 49355.4
5680.00 251.230 49288.4
5690.00 251.165 49221.4
5700.00 251.100 49154.5
5710.00 251.035 49087.6
5720.00 250.970 49020.8
5730.00 250.905 48954.2
5740.00 250.840 48887.5
5750.00 250.775 48821.0
5760.00 250.710 48754.5
5770.00 250.645 48688.1
5780.00 250.580 48621.8
5790.00 250.515 48555.5
5800.00 250.450 48489.4
5810.00 250.385 48423.3
5820.00 250.320 48357.2
5830.00 250.255 48291.3
5840.00 250.190 48225.4
5850.00 250.125 48159.6
5860.00 250.060 48093.8
5870.00 249.995 48028.1
5880.00 249.930 47962.5
5890.00 249.865 47897.0
5900.00 249.800 47831.6
5910.00 249.735 47766.2
5920.00 249.670 47700.9
5930.00 249.605 47635.6
5940.00 249.540 47570.5
5950.00 249.475 47505.4
5960.00 249.410 47440.4
5970.00 249.345 47375.4
5980.00 249.280 47310.6
5990.00 249.215 47245.8
6000.00 249.150 47181.0
6010.00 249.085 47116.4
6020.00 249.020 47051.8
6030.00 248.955 46987.3
6040.00 248.890 46922.8
6050.00 248.825 46858.5
6060.00 248.760 46794.2
6070.00 248.695 46729.9
6080.00 248.630 46665.8
6090.00 248.565 46601.7
6100.00 248.500 46537.7
6110.00 248.435 46473.7
6120.00 248.370 46409.9
6130.00 248.305 46346.1
6140.00 248.240 46282.3
6150.00 248.175 46218.7
6160.00 248.110 46155.1
6170.00 248.045 46091.6
6180.00 247.980 46028.1
6190.00 247.915 45964.7
6200.00 247.850 45901.4
6210.00 247.785 45838.2
6220.00 247.720 45775.0
6230.00 247.655 45711.9
6240.00 247.590 45648.9
6250.00 247.525 45586.0
6260.00 247.460 45523.1
6270.00 247.395 45460.3
6280.00 247.330 45397.5
6290.00 247.265 45334.9
6300.00 247.200 45272.3
6310.00 247.135 45209.7
6320.00 247.070 45147.3
6330.00 247.005 45084.9
6340.00 246.940 45022.5
6350.00 246.875 44960.3
6360.00 246.810 44898.1
6370.00 246.745 44836.0
6380.00 246.680 44774.0
6390.00 246.615 44712.0
6400.00 246.550 44650.1
6410.00 246.485 44588.2
6420.00 246.420 44526.5
6430.00 246.355 44464.8
6440.00 246.290 44403.2
6450.00 246.225 44341.6
6460.00 246.160 44280.1
6470.00 246.095 44218.7
6480.00 246.030 44157.3
6490.00 245.965 44096.1
6500.00 245.900 44034.8
6510.00 245.835 43973.7
6520.00 245.770 43912.6
6530.00 245.705 43851.6
6540.00 245.640 43790.7
6550.00 245.575 43729.8
6560.00 245.510 43669.0
6570.00 245.445 43608.3
6580.00 245.380 43547.6
6590.00 245.315 43487.0
6600.00 245.250 43426.5
6610.00 245.185 43366.0
6620.00 245.120 43305.6
6630.00 245.055 43245.3
6640.00 244.990 43185.1
6650.00 244.925 43124.9
6660.00 244.860 43064.8
6670.00 244.795 43004.7
6680.00 244.730 42944.7
6690.00 244.665 42884.8
6700.00 244.600 42825.0
6710.00 244.535 42765.2
6720.00 244.470 42705.5
6730.00 244.405 42645.8
6740.00 244.340 42586.3
6750.00 244.275 42526.7
6760.00 244.210 42467.3
6770.00 244.145 42407.9
6780.00 244.080 42348.6
6790.00 244.015 42289.4
6800.00 243.950 42230.2
6810.00 243.885 42171.1
6820.00 243.820 42112.1
6830.00 243.755 42053.1
6840.00 243.690 41994.2
6850.00 243.625 41935.3
6860.00 243.560 41876.6
6870.00 243.495 41817.9
6880.00 243.430 41759.2
6890.00 243.365 41700.7
6900.00 243.300 41642.2
6910.00 243.235 41583.7
6920.00 243.170 41525.3
6930.00 243.105 41467.0
6940.00 243.040 41408.8
6950.00 242.975 41350.6
6960.00 242.910 41292.5
6970.00 242.845 41234.5
6980.00 242.780 41176.5
6990.00 242.715 41118.6
7000.00 242.650 41060.7
7010.00 242.585 41003.0
7020.00 242.520 40945.3
7030.00 242.455 40887.6
7040.00 242.390 40830.0
7050.00 242.325 40772.5
7060.00 242.260 40715.1
7070.00 242.195 40657.7
7080.00 242.130 40600.4
7090.00 242.065 40543.1
7100.00 242.000 40485.9
7110.00 241.935 40428.8
7120.00 241.870 40371.7
7130.00 241.805 40314.8
7140.00 241.740 40257.8
7150.00 241.675 40201.0
7160.00 241.610 40144.2
7170.00 241.545 40087.4
7180.00 241.480 40030.8
7190.00 241.415 39974.2
7200.00 241.350 39917.6
7210.00 241.285 39861.2
7220.00 241.220 39804.8
7230.00 241.155 39748.4
7240.00 241.090 39692.1
7250.00 241.025 39635.9
7260.00 240.960 39579.8
7270.00 240.895 39523.7
7280.00 240.830 39467.7
7290.00 240.765 39411.7
7300.00 240.700 39355.8
7310.00 240.635 39300.0
7320.00 240.570 39244.2
7330.00 240.505 39188.5
7340.00 240.440 39132.9
7350.00 240.375 39077.3
7360.00 240.310 39021.8
7370.00 240.245 38966.4
7380.00 240.180 38911.0
7390.00 240.115 38855.7
7400.00 240.050 38800.4
7410.00 239.985 38745.3
7420.00 239.920 38690.1
7430.00 239.855 38635.1
7440.00 239.790 38580.1
7450.00 239.725 38525.1
7460.00 239.660 38470.3
7470.00 239.595 38415.5
7480.00 239.530 38360.7
7490.00 239.465 38306.0
7500.00 239.400 38251.4
7510.00 239.335 38196.9
7520.00 239.270 38142.4
7530.00 239.205 38087.9
7540.00 239.140 38033.6
7550.00 239.075 37979.3
7560.00 239.010 37925.0
7570.00 238.945 37870.9
7580.00 238.880 37816.7
7590.00 238.815 37762.7
7600.00 238.750 37708.7
7610.00 238.685 37654.8
7620.00 238.620 37600.9
7630.00 238.555 37547.1
7640.00 238.490 37493.4
7650.00 238.425 37439.7
7660.00 238.360 37386.1
7670.00 238.295 37332.5
7680.00 238.230 37279.0
7690.00 238.165 37225.6
7700.00 238.100 37172.2
7710.00 238.035 37118.9
7720.00 237.970 37065.7
7730.00 237.905 37012.5
7740.00 237.840 36959.4
7750.00 237.775 36906.3
7760.00 237.710 36853.3
7770.00 237.645 36800.4
7780.00 237.580 36747.5
7790.00 237.515 36694.7
7800.00 237.450 36642.0
7810.00 237.385 36589.3
7820.00 237.320 36536.7
7830.00 237.255 36484.1
7840.00 237.190 36431.6
7850.00 237.125 36379.1
7860.00 237.060 36326.8
7870.00 236.995 36274.4
7880.00 236.930 36222.2
7890.00 236.865 36170.0
7900.00 236.800 36117.8
7910.00 236.735 36065.8
7920.00 236.670 36013.8
7930.00 236.605 35961.8
7940.00 236.540 35909.9
7950.00 236.475 35858.1
7960.00 236.410 35806.3
7970.00 236.345 35754.6
7980.00 236.280 35702.9
7990.00 236.215 35651.3
8000.00 236.150 35599.8
8010.00 236.085 35548.3
8020.00 236.020 35496.9
8030.00 235.955 35445.6
8040.00 235.890 35394.3
8050.00 235.825 35343.1
8060.00 235.760 35291.9
8070.00 235.695 35240.8
8080.00 235.630 35189.7
8090.00 235.565 35138.7
8100.00 235.500 35087.8
8110.00 235.435 35036.9
8120.00 235.370 34986.1
8130.00 235.305 34935.4
8140.00 235.240 34884.7
8150.00 235.175 34834.0
8160.00 235.110 34783.5
8170.00 235.045 34733.0
8180.00 234.980 34682.5
8190.00 234.915 34632.1
8200.00 234.850 34581.8
8210.00 234.785 34531.5
8220.00 234.720 34481.3
8230.00 234.655 34431.1
8240.00 234.590 34381.0
8250.00 234.525 34331.0
8260.00 234.460 34281.0
8270.00 234.395 34231.1
8280.00 234.330 34181.2
8290.00 234.265 34131.4
8300.00 234.200 34081.7
8310.00 234.135 34032.0
8320.00 234.070 33982.4
8330.00 234.005 33932.8
8340.00 233.940 33883.3
8350.00 233.875 33833.8
8360.00 233.810 33784.4
8370.00 233.745 33735.1
8380.00 233.680 33685.8
8390.00 233.615 33636.6
8400.00 233.550 33587.5
8410.00 233.485 33538.3
8420.00 233.420 33489.3
8430.00 233.355 33440.3
8440.00 233.290 33391.4
8450.00 233.225 33342.5
8460.00 233.160 33293.7
8470.00 233.095 33245.0
8480.00 233.030 33196.3
8490.00 232.965 33147.6
8500.00 232.900 33099.0
8510.00 232.835 33050.5
8520.00 232.770 33002.1
8530.00 232.705 32953.6
8540.00 232.640 32905.3
8550.00 232.575 32857.0
8560.00 232.510 32808.8
8570.00 232.445 32760.6
8580.00 232.380 32712.5
8590.00 232.315 32664.4
8600.00 232.250 32616.4
8610.00 232.185 32568.4
8620.00 232.120 32520.6
8630.00 232.055 32472.7
8640.00 231.990 32424.9
8650.00 231.925 32377.2
8660.00 231.860 32329.6
8670.00 231.795 32282.0
8680.00 231.730 32234.4
8690.00 231.665 32186.9
8700.00 231.600 32139.5
8710.00 231.535 32092.1
8720.00 231.470 32044.8
8730.00 231.405 31997.5
8740.00 231.340 31950.3
8750.00 231.275 31903.1
8760.00 231.210 31856.0
8770.00 231.145 31809.0
8780.00 231.080 31762.0
8790.00 231.015 31715.1
8800.00 230.950 31668.2
8810.00 230.885 31621.4
8820.00 230.820 31574.6
8830.00 230.755 31527.9
8840.00 230.690 31481.3
8850.00 230.625 31434.7
8860.00 230.560 31388.1
8870.00 230.495 31341.7
8880.00 230.430 31295.2
8890.00 230.365 31248.9
8900.00 230.300 31202.6
8910.00 230.235 31156.3
8920.00 230.170 31110.1
8930.00 230.105 31063.9
8940.00 230.040 31017.9
8950.00 229.975 30971.8
8960.00 229.910 30925.8
8970.00 229.845 30879.9
8980.00 229.780 30834.0
8990.00 229.715 30788.2
9000.00 229.650 30742.5
9010.00 229.585 30696.8
9020.00 229.520 30651.1
9030.00 229.455 30605.5
9040.00 229.390 30560.0
9050.00 229.325 30514.5
9060.00 229.260 30469.0
9070.00 229.195 30423.7
9080.00 229.130 30378.4
9090.00 229.065 30333.1
9100.00 229.000 30287.9
9110.00 228.935 30242.7
9120.00 228.870 30197.6
9130.00 228.805 30152.6
9140.00 228.740 30107.6
9150.00 228.675 30062.6
9160.00 228.610 30017.7
9170.00 228.545 29972.9
9180.00 228.480 29928.1
9190.00 228.415 29883.4
9200.00 228.350 29838.7
9210.00 228.285 29794.1
9220.00 228.220 29749.6
9230.00 228.155 29705.1
9240.00 228.090 29660.6
9250.00 228.025 29616.2
9260.00 227.960 29571.9
9270.00 227.895 29527.6
9280.00 227.830 29483.3
9290.00 227.765 29439.2
9300.00 227.700 29395.0
9310.00 227.635 29351.0
9320.00 227.570 29306.9
9330.00 227.505 29263.0
9340.00 227.440 29219.0
9350.00 227.375 29175.2
9360.00 227.310 29131.4
9370.00 227.245 29087.6
9380.00 227.180 29043.9
9390.00 227.115 29000.3
9400.00 227.050 28956.7
9410.00 226.985 28913.1
9420.00 226.920 28869.6
9430.00 226.855 28826.2
9440.00 226.790 28782.8
9450.00 226.725 28739.5
9460.00 226.660 28696.2
9470.00 226.595 28653.0
9480.00 226.530 28609.8
9490.00 226.465 28566.7
9500.00 226.400 28523.6
9510.00 226.335 28480.6
9520.00 226.270 28437.6
9530.00 226.205 28394.7
9540.00 226.140 28351.9
9550.00 226.075 28309.1
9560.00 226.010 28266.3
9570.00 225.945 28223.6
9580.00 225.880 28181.0
9590.00 225.815 28138.4
9600.00 225.750 28095.8
9610.00 225.685 28053.3
9620.00 225.620 28010.9
9630.00 225.555 27968.5
9640.00 225.490 27926.2
9650.00 225.425 27883.9
9660.00 225.360 27841.7
9670.00 225.295 27799.5
9680.00 225.230 27757.3
9690.00 225.165 27715.3
9700.00 225.100 27673.2
9710.00 225.035 27631.3
9720.00 224.970 27589.3
9730.00 224.905 27547.5
9740.00 224.840 27505.7
9750.00 224.775 27463.9
9760.00 224.710 27422.2
9770.00 224.645 27380.5
9780.00 224.580 27338.9
9790.00 224.515 27297.3
9800.00 224.450 27255.8
9810.00 224.385 27214.4
9820.00 224.320 27172.9
9830.00 224.255 27131.6
9840.00 224.190 27090.3
9850.00 224.125 27049.0
9860.00 224.060 27007.8
9870.00 223.995 26966.7
9880.00 223.930 26925.6
9890.00 223.865 26884.5
9900.00 223.800 26843.5
9910.00 223.735 26802.6
9920.00 223.670 26761.7
9930.00 223.605 26720.8
9940.00 223.540 26680.0
9950.00 223.475 26639.3
9960.00 223.410 26598.6
9970.00 223.345 26557.9
9980.00 223.280 26517.3
9990.00 223.215 26476.8
10000.0 223.150 26436.3
10010.0 223.085 26395.8
10020.0 223.020 26355.4
10030.0 222.955 26315.1
10040.0 222.890 26274.8
10050.0 222.825 26234.5
10060.0 222.760 26194.3
10070.0 222.695 26154.2
10080.0 222.630 26114.1
10090.0 222.565 26074.0
10100.0 222.500 26034.0
10110.0 222.435 25994.1
10120.0 222.370 25954.2
10130.0 222.305 25914.3
10140.0 222.240 25874.5
10150.0 222.175 25834.8
10160.0 222.110 25795.1
10170.0 222.045 25755.4
10180.0 221.980 25715.8
10190.0 221.915 25676.3
10200.0 221.850 25636.8
10210.0 221.785 25597.3
10220.0 221.720 25557.9
10230.0 221.655 25518.6
10240.0 221.590 25479.3
10250.0 221.525 25440.0
10260.0 221.460 25400.8
10270.0 221.395 25361.6
10280.0 221.330 25322.5
10290.0 221.265 25283.5
10300.0 221.200 25244.5
10310.0 221.135 25205.5
10320.0 221.070 25166.6
10330.0 221.005 25127.7
10340.0 220.940 25088.9
10350.0 220.875 25050.1
10360.0 220.810 25011.4
10370.0 220.745 24972.7
10380.0 220.680 24934.1
10390.0 220.615 24895.5
10400.0 220.550 24857.0
10410.0 220.485 24818.5
10420.0 220.420 24780.1
10430.0 220.355 24741.7
10440.0 220.290 24703.4
10450.0 220.225 24665.1
10460.0 220.160 24626.8
10470.0 220.095 24588.7
10480.0 220.030 24550.5
10490.0 219.965 24512.4
10500.0 219.900 24474.4
10510.0 219.835 24436.4
10520.0 219.770 24398.4
10530.0 219.705 24360.5
10540.0 219.640 24322.7
10550.0 219.575 24284.9
10560.0 219.510 24247.1
10570.0 219.445 24209.4
10580.0 219.380 24171.7
10590.0 219.315 24134.1
10600.0 219.250 24096.5
10610.0 219.185 24059.0
10620.0 219.120 24021.5
10630.0 219.055 23984.1
10640.0 218.990 23946.7
10650.0 218.925 23909.4
10660.0 218.860 23872.1
10670.0 218.795 23834.9
10680.0 218.730 23797.7
10690.0 218.665 23760.5
10700.0 218.600 23723.4
10710.0 218.535 23686.4
10720.0 218.470 23649.4
10730.0 218.405 23612.4
10740.0 218.340 23575.5
10750.0 218.275 23538.6
10760.0 218.210 23501.8
10770.0 218.145 23465.0
10780.0 218.080 23428.3
10790.0 218.015 23391.6
10800.0 217.950 23355.0
10810.0 217.885 23318.4
10820.0 217.820 23281.9
10830.0 217.755 23245.4
10840.0 217.690 23208.9
10850.0 217.625 23172.5
10860.0 217.560 23136.2
10870.0 217.495 23099.9
10880.0 217.430 23063.6
10890.0 217.365 23027.4
10900.0 217.300 22991.2
10910.0 217.235 22955.1
10920.0 217.170 22919.0
10930.0 217.105 22883.0
10940.0 217.040 22847.0
10950.0 216.975 22811.1
10960.0 216.910 22775.2
10970.0 216.845 22739.3
10980.0 216.780 22703.5
10990.0 216.715 22667.8
11000.0 216.650 22632.1
11010.0 216.650 22596.4
11020.0 216.650 22560.8
11030.0 216.650 22525.3
11040.0 216.650 22489.8
11050.0 216.650 22454.3
11060.0 216.650 22418.9
11070.0 216.650 22383.6
11080.0 216.650 22348.4
11090.0 216.650 22313.1
11100.0 216.650 22278.0
11110.0 216.650 22242.9
11120.0 216.650 22207.8
11130.0 216.650 22172.8
11140.0 216.650 22137.9
11150.0 216.650 22103.0
11160.0 216.650 22068.2
11170.0 216.650 22033.4
11180.0 216.650 21998.7
11190.0 216.650 21964.0
11200.0 216.650 21929.4
11210.0 216.650 21894.9
11220.0 216.650 21860.4
11230.0 216.650 21825.9
11240.0 216.650 21791.6
11250.0 216.650 21757.2
11260.0 216.650 21722.9
11270.0 216.650 21688.7
11280.0 216.650 21654.5
11290.0 216.650 21620.4
11300.0 216.650 21586.3
11310.0 216.650 21552.3
11320.0 216.650 21518.4
11330.0 216.650 21484.5
11340.0 216.650 21450.6
11350.0 216.650 21416.8
11360.0 216.650 21383.1
11370.0 216.650 21349.4
11380.0 216.650 21315.7
11390.0 216.650 21282.2
11400.0 216.650 21248.6
11410.0 216.650 21215.1
11420.0 216.650 21181.7
11430.0 216.650 21148.3
11440.0 216.650 21115.0
11450.0 216.650 21081.8
11460.0 216.650 21048.5
11470.0 216.650 21015.4
11480.0 216.650 20982.3
11490.0 216.650 20949.2
11500.0 216.650 20916.2
11510.0 216.650 20883.2
11520.0 216.650 20850.3
11530.0 216.650 20817.5
11540.0 216.650 20784.7
11550.0 216.650 20751.9
11560.0 216.650 20719.2
11570.0 216.650 20686.6
11580.0 216.650 20654.0
11590.0 216.650 20621.4
11600.0 216.650 20589.0
11610.0 216.650 20556.5
11620.0 216.650 20524.1
11630.0 216.650 20491.8
11640.0 216.650 20459.5
11650.0 216.650 20427.3
11660.0 216.650 20395.1
11670.0 216.650 20362.9
11680.0 216.650 20330.9
11690.0 216.650 20298.8
11700.0 216.650 20266.8
11710.0 216.650 20234.9
11720.0 216.650 20203.0
11730.0 216.650 20171.2
11740.0 216.650 20139.4
11750.0 216.650 20107.7
11760.0 216.650 20076.0
11770.0 216.650 20044.4
11780.0 216.650 20012.8
11790.0 216.650 19981.2
11800.0 216.650 19949.8
11810.0 216.650 19918.3
11820.0 216.650 19886.9
11830.0 216.650 19855.6
11840.0 216.650 19824.3
11850.0 216.650 19793.1
11860.0 216.650 19761.9
11870.0 216.650 19730.8
11880.0 216.650 19699.7
11890.0 216.650 19668.6
11900.0 216.650 19637.6
11910.0 216.650 19606.7
11920.0 216.650 19575.8
11930.0 216.650 19545.0
11940.0 216.650 19514.2
11950.0 216.650 19483.4
11960.0 216.650 19452.7
11970.0 216.650 19422.1
11980.0 216.650 19391.5
11990.0 216.650 19360.9
12000.0 216.650 19330.4
12010.0 216.650 19299.9
12020.0 216.650 19269.5
12030.0 216.650 19239.2
12040.0 216.650 19208.9
12050.0 216.650 19178.6
12060.0 216.650 19148.4
12070.0 216.650 19118.2
12080.0 216.650 19088.1
12090.0 216.650 19058.0
12100.0 216.650 19028.0
12110.0 216.650 18998.0
12120.0 216.650 18968.1
12130.0 216.650 18938.2
12140.0 216.650 18908.3
12150.0 216.650 18878.5
12160.0 216.650 18848.8
12170.0 216.650 18819.1
12180.0 216.650 18789.4
12190.0 216.650 18759.8
12200.0 216.650 18730.3
12210.0 216.650 18700.8
12220.0 216.650 18671.3
12230.0 216.650 18641.9
12240.0 216.650 18612.5
12250.0 216.650 18583.2
12260.0 216.650 18553.9
12270.0 216.650 18524.7
12280.0 216.650 18495.5
12290.0 216.650 18466.3
12300.0 216.650 18437.2
12310.0 216.650 18408.2
12320.0 216.650 18379.2
12330.0 216.650 18350.2
12340.0 216.650 18321.3
12350.0 216.650 18292.4
12360.0 216.650 18263.6
12370.0 216.650 18234.8
12380.0 216.650 18206.1
12390.0 216.650 18177.4
12400.0 216.650 18148.8
12410.0 216.650 18120.2
12420.0 216.650 18091.6
12430.0 216.650 18063.1
12440.0 216.650 18034.7
12450.0 216.650 18006.3
12460.0 216.650 17977.9
12470.0 216.650 17949.6
12480.0 216.650 17921.3
12490.0 216.650 17893.0
12500.0 216.650 17864.8
12510.0 216.650 17836.7
12520.0 216.650 17808.6
12530.0 216.650 17780.5
12540.0 216.650 17752.5
12550.0 216.650 17724.5
12560.0 216.650 17696.6
12570.0 216.650 17668.7
12580.0 216.650 17640.9
12590.0 216.650 17613.1
12600.0 216.650 17585.4
12610.0 216.650 17557.6
12620.0 216.650 17530.0
12630.0 216.650 17502.4
12640.0 216.650 17474.8
12650.0 216.650 17447.2
12660.0 216.650 17419.8
12670.0 216.650 17392.3
12680.0 216.650 17364.9
12690.0 216.650 17337.5
12700.0 216.650 17310.2
12710.0 216.650 17283.0
12720.0 216.650 17255.7
12730.0 216.650 17228.5
12740.0 216.650 17201.4
12750.0 216.650 17174.3
12760.0 216.650 17147.2
12770.0 216.650 17120.2
12780.0 216.650 17093.2
12790.0 216.650 17066.3
12800.0 216.650 17039.4
12810.0 216.650 17012.6
12820.0 216.650 16985.7
12830.0 216.650 16959.0
12840.0 216.650 16932.3
12850.0 216.650 16905.6
12860.0 216.650 16878.9
12870.0 216.650 16852.4
12880.0 216.650 16825.8
12890.0 216.650 16799.3
12900.0 216.650 16772.8
12910.0 216.650 16746.4
12920.0 216.650 16720.0
12930.0 216.650 16693.7
12940.0 216.650 16667.4
12950.0 216.650 16641.1
12960.0 216.650 16614.9
12970.0 216.650 16588.7
12980.0 216.650 16562.6
12990.0 216.650 16536.5
13000.0 216.650 16510.4
13010.0 216.650 16484.4
13020.0 216.650 16458.4
13030.0 216.650 16432.5
13040.0 216.650 16406.6
13050.0 216.650 16380.7
13060.0 216.650 16354.9
13070.0 216.650 16329.2
13080.0 216.650 16303.4
13090.0 216.650 16277.7
13100.0 216.650 16252.1
13110.0 216.650 16226.5
13120.0 216.650 16200.9
13130.0 216.650 16175.4
13140.0 216.650 16149.9
13150.0 216.650 16124.5
13160.0 216.650 16099.1
13170.0 216.650 16073.7
13180.0 216.650 16048.4
13190.0 216.650 16023.1
13200.0 216.650 15997.8
13210.0 216.650 15972.6
13220.0 216.650 15947.5
13230.0 216.650 15922.3
13240.0 216.650 15897.2
13250.0 216.650 15872.2
13260.0 216.650 15847.2
13270.0 216.650 15822.2
13280.0 216.650 15797.3
13290.0 216.650 15772.4
13300.0 216.650 15747.5
13310.0 216.650 15722.7
13320.0 216.650 15698.0
13330.0 216.650 15673.2
13340.0 216.650 15648.5
13350.0 216.650 15623.9
13360.0 216.650 15599.3
13370.0 216.650 15574.7
13380.0 216.650 15550.1
13390.0 216.650 15525.6
13400.0 216.650 15501.2
13410.0 216.650 15476.7
13420.0 216.650 15452.4
13430.0 216.650 15428.0
13440.0 216.650 15403.7
13450.0 216.650 15379.4
13460.0 216.650 15355.2
13470.0 216.650 15331.0
13480.0 216.650 15306.8
13490.0 216.650 15282.7
13500.0 216.650 15258.7
13510.0 216.650 15234.6
13520.0 216.650 15210.6
13530.0 216.650 15186.6
13540.0 216.650 15162.7
13550.0 216.650 15138.8
13560.0 216.650 15115.0
13570.0 216.650 15091.1
13580.0 216.650 15067.4
13590.0 216.650 15043.6
13600.0 216.650 15019.9
13610.0 216.650 14996.3
13620.0 216.650 14972.6
13630.0 216.650 14949.0
13640.0 216.650 14925.5
13650.0 216.650 14902.0
13660.0 216.650 14878.5
13670.0 216.650 14855.0
13680.0 216.650 14831.6
13690.0 216.650 14808.3
13700.0 216.650 14784.9
13710.0 216.650 14761.6
13720.0 216.650 14738.4
13730.0 216.650 14715.2
13740.0 216.650 14692.0
13750.0 216.650 14668.8
13760.0 216.650 14645.7
13770.0 216.650 14622.6
13780.0 216.650 14599.6
13790.0 216.650 14576.6
13800.0 216.650 14553.6
13810.0 216.650 14530.7
13820.0 216.650 14507.8
13830.0 216.650 14484.9
13840.0 216.650 14462.1
13850.0 216.650 14439.3
13860.0 216.650 14416.6
13870.0 216.650 14393.9
13880.0 216.650 14371.2
13890.0 216.650 14348.5
13900.0 216.650 14325.9
13910.0 216.650 14303.4
13920.0 216.650 14280.8
13930.0 216.650 14258.3
13940.0 216.650 14235.9
13950.0 216.650 14213.4
13960.0 216.650 14191.0
13970.0 216.650 14168.7
13980.0 216.650 14146.3
13990.0 216.650 14124.1
14000.0 216.650 14101.8
14010.0 216.650 14079.6
14020.0 216.650 14057.4
14030.0 216.650 14035.2
14040.0 216.650 14013.1
14050.0 216.650 13991.1
14060.0 216.650 13969.0
14070.0 216.650 13947.0
14080.0 216.650 13925.0
14090.0 216.650 13903.1
14100.0 216.650 13881.2
14110.0 216.650 13859.3
14120.0 216.650 13837.5
14130.0 216.650 13815.7
14140.0 216.650 13793.9
14150.0 216.650 13772.2
14160.0 216.650 13750.5
14170.0 216.650 13728.8
14180.0 216.650 13707.2
14190.0 216.650 13685.6
14200.0 216.650 13664.0
14210.0 216.650 13642.5
14220.0 216.650 13621.0
14230.0 216.650 13599.5
14240.0 216.650 13578.1
14250.0 216.650 13556.7
14260.0 216.650 13535.3
14270.0 216.650 13514.0
14280.0 216.650 13492.7
14290.0 216.650 13471.5
14300.0 216.650 13450.2
14310.0 216.650 13429.0
14320.0 216.650 13407.9
14330.0 216.650 13386.7
14340.0 216.650 13365.7
14350.0 216.650 13344.6
14360.0 216.650 13323.6
14370.0 216.650 13302.6
14380.0 216.650 13281.6
14390.0 216.650 13260.7
14400.0 216.650 13239.8
14410.0 216.650 13218.9
14420.0 216.650 13198.1
14430.0 216.650 13177.3
14440.0 216.650 13156.5
14450.0 216.650 13135.8
14460.0 216.650 13115.1
14470.0 216.650 13094.5
14480.0 216.650 13073.8
14490.0 216.650 13053.2
14500.0 216.650 13032.7
14510.0 216.650 13012.1
14520.0 216.650 12991.6
14530.0 216.650 12971.1
14540.0 216.650 12950.7
14550.0 216.650 12930.3
14560.0 216.650 12909.9
14570.0 216.650 12889.6
14580.0 216.650 12869.3
14590.0 216.650 12849.0
14600.0 216.650 12828.8
14610.0 216.650 12808.5
14620.0 216.650 12788.4
14630.0 216.650 12768.2
14640.0 216.650 12748.1
14650.0 216.650 12728.0
14660.0 216.650 12708.0
14670.0 216.650 12687.9
14680.0 216.650 12667.9
14690.0 216.650 12648.0
14700.0 216.650 12628.1
14710.0 216.650 12608.2
14720.0 216.650 12588.3
14730.0 216.650 12568.5
14740.0 216.650 12548.6
14750.0 216.650 12528.9
14760.0 216.650 12509.1
14770.0 216.650 12489.4
14780.0 216.650 12469.7
14790.0 216.650 12450.1
14800.0 216.650 12430.5
14810.0 216.650 12410.9
14820.0 216.650 12391.3
14830.0 216.650 12371.8
14840.0 216.650 12352.3
14850.0 216.650 12332.9
14860.0 216.650 12313.4
14870.0 216.650 12294.0
14880.0 216.650 12274.7
14890.0 216.650 12255.3
14900.0 216.650 12236.0
14910.0 216.650 12216.7
14920.0 216.650 12197.5
14930.0 216.650 12178.3
14940.0 216.650 12159.1
14950.0 216.650 12139.9
14960.0 216.650 12120.8
14970.0 216.650 12101.7
14980.0 216.650 12082.6
14990.0 216.650 12063.6
15000.0 216.650 12044.6
15010.0 216.650 12025.6
15020.0 216.650 12006.6
15030.0 216.650 11987.7
15040.0 216.650 11968.8
15050.0 216.650 11950.0
15060.0 216.650 11931.2
15070.0 216.650 11912.4
15080.0 216.650 11893.6
15090.0 216.650 11874.8
15100.0 216.650 11856.1
15110.0 216.650 11837.5
15120.0 216.650 11818.8
15130.0 216.650 11800.2
15140.0 216.650 11781.6
15150.0 216.650 11763.0
15160.0 216.650 11744.5
15170.0 216.650 11726.0
15180.0 216.650 11707.5
15190.0 216.650 11689.1
15200.0 216.650 11670.6
15210.0 216.650 11652.3
15220.0 216.650 11633.9
15230.0 216.650 11615.6
15240.0 216.650 11597.3
15250.0 216.650 11579.0
15260.0 216.650 11560.7
15270.0 216.650 11542.5
15280.0 216.650 11524.3
15290.0 216.650 11506.2
15300.0 216.650 11488.1
15310.0 216.650 11470.0
15320.0 216.650 11451.9
15330.0 216.650 11433.8
15340.0 216.650 11415.8
15350.0 216.650 11397.8
15360.0 216.650 11379.9
15370.0 216.650 11361.9
15380.0 216.650 11344.0
15390.0 216.650 11326.2
15400.0 216.650 11308.3
15410.0 216.650 11290.5
15420.0 216.650 11272.7
15430.0 216.650 11254.9
15440.0 216.650 11237.2
15450.0 216.650 11219.5
15460.0 216.650 11201.8
15470.0 216.650 11184.2
15480.0 216.650 11166.6
15490.0 216.650 11149.0
15500.0 216.650 11131.4
15510.0 216.650 11113.9
15520.0 216.650 11096.3
15530.0 216.650 11078.9
15540.0 216.650 11061.4
15550.0 216.650 11044.0
15560.0 216.650 11026.6
15570.0 216.650 11009.2
15580.0 216.650 10991.9
15590.0 216.650 10974.5
15600.0 216.650 10957.2
15610.0 216.650 10940.0
15620.0 216.650 10922.7
15630.0 216.650 10905.5
15640.0 216.650 10888.4
15650.0 216.650 10871.2
15660.0 216.650 10854.1
15670.0 216.650 10837.0
15680.0 216.650 10819.9
15690.0 216.650 10802.8
15700.0 216.650 10785.8
15710.0 216.650 10768.8
15720.0 216.650 10751.9
15730.0 216.650 10734.9
15740.0 216.650 10718.0
15750.0 216.650 10701.1
15760.0 216.650 10684.3
15770.0 216.650 10667.4
15780.0 216.650 10650.6
15790.0 216.650 10633.8
15800.0 216.650 10617.1
15810.0 216.650 10600.3
15820.0 216.650 10583.6
15830.0 216.650 10567.0
15840.0 216.650 10550.3
15850.0 216.650 10533.7
15860.0 216.650 10517.1
15870.0 216.650 10500.5
15880.0 216.650 10484.0
15890.0 216.650 10467.5
15900.0 216.650 10451.0
15910.0 216.650 10434.5
15920.0 216.650 10418.1
15930.0 216.650 10401.6
15940.0 216.650 10385.3
15950.0 216.650 10368.9
15960.0 216.650 10352.6
15970.0 216.650 10336.2
15980.0 216.650 10320.0
15990.0 216.650 10303.7
16000.0 216.650 10287.5
16010.0 216.650 10271.2
16020.0 216.650 10255.1
16030.0 216.650 10238.9
16040.0 216.650 10222.8
16050.0 216.650 10206.7
16060.0 216.650 10190.6
16070.0 216.650 10174.5
16080.0 216.650 10158.5
16090.0 216.650 10142.5
16100.0 216.650 10126.5
16110.0 216.650 10110.6
16120.0 216.650 10094.6
16130.0 216.650 10078.7
16140.0 216.650 10062.8
16150.0 216.650 10047.0
16160.0 216.650 10031.2
16170.0 216.650 10015.3
16180.0 216.650 9999.57
16190.0 216.650 9983.81
16200.0 216.650 9968.08
16210.0 216.650 9952.37
16220.0 216.650 9936.69
16230.0 216.650 9921.04
16240.0 216.650 9905.40
16250.0 216.650 9889.80
16260.0 216.650 9874.21
16270.0 216.650 9858.65
16280.0 216.650 9843.12
16290.0 216.650 9827.61
16300.0 216.650 9812.13
16310.0 216.650 9796.67
16320.0 216.650 9781.23
16330.0 216.650 9765.82
16340.0 216.650 9750.43
16350.0 216.650 9735.07
16360.0 216.650 9719.73
16370.0 216.650 9704.41
16380.0 216.650 9689.12
16390.0 216.650 9673.86
16400.0 216.650 9658.61
16410.0 216.650 9643.40
16420.0 216.650 9628.20
16430.0 216.650 9613.03
16440.0 216.650 9597.88
16450.0 216.650 9582.76
16460.0 216.650 9567.66
16470.0 216.650 9552.59
16480.0 216.650 9537.54
16490.0 216.650 9522.51
16500.0 216.650 9507.50
16510.0 216.650 9492.52
16520.0 216.650 9477.57
16530.0 216.650 9462.63
16540.0 216.650 9447.72
16550.0 216.650 9432.84
16560.0 216.650 9417.97
16570.0 216.650 9403.14
16580.0 216.650 9388.32
16590.0 216.650 9373.53
16600.0 216.650 9358.76
16610.0 216.650 9344.01
16620.0 216.650 9329.29
16630.0 216.650 9314.59
16640.0 216.650 9299.91
16650.0 216.650 9285.26
16660.0 216.650 9270.63
16670.0 216.650 9256.02
16680.0 216.650 9241.44
16690.0 216.650 9226.88
16700.0 216.650 9212.34
16710.0 216.650 9197.82
16720.0 216.650 9183.33
16730.0 216.650 9168.86
16740.0 216.650 9154.41
16750.0 216.650 9139.99
16760.0 216.650 9125.59
16770.0 216.650 9111.21
16780.0 216.650 9096.85
16790.0 216.650 9082.52
16800.0 216.650 9068.21
16810.0 216.650 9053.92
16820.0 216.650 9039.66
16830.0 216.650 9025.41
16840.0 216.650 9011.19
16850.0 216.650 8996.99
16860.0 216.650 8982.82
16870.0 216.650 8968.66
16880.0 216.650 8954.53
16890.0 216.650 8940.42
16900.0 216.650 8926.34
16910.0 216.650 8912.27
16920.0 216.650 8898.23
16930.0 216.650 8884.21
16940.0 216.650 8870.21
16950.0 216.650 8856.23
16960.0 216.650 8842.28
16970.0 216.650 8828.35
16980.0 216.650 8814.44
16990.0 216.650 8800.55
17000.0 216.650 8786.68
17010.0 216.650 8772.84
17020.0 216.650 8759.01
17030.0 216.650 8745.21
17040.0 216.650 8731.43
17050.0 216.650 8717.68
17060.0 216.650 8703.94
17070.0 216.650 8690.23
17080.0 216.650 8676.53
17090.0 216.650 8662.86
17100.0 216.650 8649.21
17110.0 216.650 8635.58
17120.0 216.650 8621.98
17130.0 216.650 8608.39
17140.0 216.650 8594.83
17150.0 216.650 8581.29
17160.0 216.650 8567.77
17170.0 216.650 8554.27
17180.0 216.650 8540.79
17190.0 216.650 8527.33
17200.0 216.650 8513.89
17210.0 216.650 8500.48
17220.0 216.650 8487.09
17230.0 216.650 8473.71
17240.0 216.650 8460.36
17250.0 216.650 8447.03
17260.0 216.650 8433.72
17270.0 216.650 8420.43
17280.0 216.650 8407.17
17290.0 216.650 8393.92
17300.0 216.650 8380.69
17310.0 216.650 8367.49
17320.0 216.650 8354.30
17330.0 216.650 8341.14
17340.0 216.650 8328.00
17350.0 216.650 8314.88
17360.0 216.650 8301.78
17370.0 216.650 8288.69
17380.0 216.650 8275.63
17390.0 216.650 8262.59
17400.0 216.650 8249.58
17410.0 216.650 8236.58
17420.0 216.650 8223.60
17430.0 216.650 8210.64
17440.0 216.650 8197.71
17450.0 216.650 8184.79
17460.0 216.650 8171.89
17470.0 216.650 8159.02
17480.0 216.650 8146.16
17490.0 216.650 8133.33
17500.0 216.650 8120.51
17510.0 216.650 8107.72
17520.0 216.650 8094.94
17530.0 216.650 8082.19
17540.0 216.650 8069.45
17550.0 216.650 8056.74
17560.0 216.650 8044.04
17570.0 216.650 8031.37
17580.0 216.650 8018.71
17590.0 216.650 8006.08
17600.0 216.650 7993.46
17610.0 216.650 7980.87
17620.0 216.650 7968.29
17630.0 216.650 7955.74
17640.0 216.650 7943.20
17650.0 216.650 7930.69
17660.0 216.650 7918.19
17670.0 216.650 7905.72
17680.0 216.650 7893.26
17690.0 216.650 7880.82
17700.0 216.650 7868.40
17710.0 216.650 7856.01
17720.0 216.650 7843.63
17730.0 216.650 7831.27
17740.0 216.650 7818.93
17750.0 216.650 7806.61
17760.0 216.650 7794.31
17770.0 216.650 7782.03
17780.0 216.650 7769.77
17790.0 216.650 7757.52
17800.0 216.650 7745.30
17810.0 216.650 7733.10
17820.0 216.650 7720.91
17830.0 216.650 7708.75
17840.0 216.650 7696.60
17850.0 216.650 7684.47
17860.0 216.650 7672.37
17870.0 216.650 7660.28
17880.0 216.650 7648.21
17890.0 216.650 7636.16
17900.0 216.650 7624.13
17910.0 216.650 7612.11
17920.0 216.650 7600.12
17930.0 216.650 7588.14
17940.0 216.650 7576.19
17950.0 216.650 7564.25
17960.0 216.650 7552.33
17970.0 216.650 7540.43
17980.0 216.650 7528.55
17990.0 216.650 7516.69
18000.0 216.650 7504.84
18010.0 216.650 7493.02
18020.0 216.650 7481.21
18030.0 216.650 7469.43
18040.0 216.650 7457.66
18050.0 216.650 7445.91
18060.0 216.650 7434.17
18070.0 216.650 7422.46
18080.0 216.650 7410.77
18090.0 216.650 7399.09
18100.0 216.650 7387.43
18110.0 216.650 7375.79
18120.0 216.650 7364.17
18130.0 216.650 7352.57
18140.0 216.650 7340.98
18150.0 216.650 7329.41
18160.0 216.650 7317.87
18170.0 216.650 7306.33
18180.0 216.650 7294.82
18190.0 216.650 7283.33
18200.0 216.650 7271.85
18210.0 216.650 7260.39
18220.0 216.650 7248.95
18230.0 216.650 7237.53
18240.0 216.650 7226.13
18250.0 216.650 7214.74
18260.0 216.650 7203.38
18270.0 216.650 7192.03
18280.0 216.650 7180.69
18290.0 216.650 7169.38
18300.0 216.650 7158.08
18310.0 216.650 7146.80
18320.0 216.650 7135.54
18330.0 216.650 7124.30
18340.0 216.650 7113.08
18350.0 216.650 7101.87
18360.0 216.650 7090.68
18370.0 216.650 7079.51
18380.0 216.650 7068.35
18390.0 216.650 7057.21
18400.0 216.650 7046.09
18410.0 216.650 7034.99
18420.0 216.650 7023.91
18430.0 216.650 7012.84
18440.0 216.650 7001.79
18450.0 216.650 6990.76
18460.0 216.650 6979.74
18470.0 216.650 6968.75
18480.0 216.650 6957.77
18490.0 216.650 6946.80
18500.0 216.650 6935.86
18510.0 216.650 6924.93
18520.0 216.650 6914.02
18530.0 216.650 6903.12
18540.0 216.650 6892.25
18550.0 216.650 6881.39
18560.0 216.650 6870.54
18570.0 216.650 6859.72
18580.0 216.650 6848.91
18590.0 216.650 6838.12
18600.0 216.650 6827.34
18610.0 216.650 6816.59
18620.0 216.650 6805.85
18630.0 216.650 6795.12
18640.0 216.650 6784.42
18650.0 216.650 6773.73
18660.0 216.650 6763.05
18670.0 216.650 6752.40
18680.0 216.650 6741.76
18690.0 216.650 6731.13
18700.0 216.650 6720.53
18710.0 216.650 6709.94
18720.0 216.650 6699.37
18730.0 216.650 6688.81
18740.0 216.650 6678.27
18750.0 216.650 6667.75
18760.0 216.650 6657.24
18770.0 216.650 6646.75
18780.0 216.650 6636.28
18790.0 216.650 6625.83
18800.0 216.650 6615.39
18810.0 216.650 6604.96
18820.0 216.650 6594.55
18830.0 216.650 6584.16
18840.0 216.650 6573.79
18850.0 216.650 6563.43
18860.0 216.650 6553.09
18870.0 216.650 6542.76
18880.0 216.650 6532.46
18890.0 216.650 6522.16
18900.0 216.650 6511.89
18910.0 216.650 6501.63
18920.0 216.650 6491.38
18930.0 216.650 6481.15
18940.0 216.650 6470.94
18950.0 216.650 6460.75
18960.0 216.650 6450.57
18970.0 216.650 6440.40
18980.0 216.650 6430.25
18990.0 216.650 6420.12
19000.0 216.650 6410.01
19010.0 216.650 6399.91
19020.0 216.650 6389.82
19030.0 216.650 6379.76
19040.0 216.650 6369.70
19050.0 216.650 6359.67
19060.0 216.650 6349.65
19070.0 216.650 6339.64
19080.0 216.650 6329.65
19090.0 216.650 6319.68
19100.0 216.650 6309.72
19110.0 216.650 6299.78
19120.0 216.650 6289.85
19130.0 216.650 6279.94
19140.0 216.650 6270.05
19150.0 216.650 6260.17
19160.0 216.650 6250.30
19170.0 216.650 6240.46
19180.0 216.650 6230.62
19190.0 216.650 6220.81
19200.0 216.650 6211.00
19210.0 216.650 6201.22
19220.0 216.650 6191.45
19230.0 216.650 6181.69
19240.0 216.650 6171.95
19250.0 216.650 6162.23
19260.0 216.650 6152.52
19270.0 216.650 6142.82
19280.0 216.650 6133.14
19290.0 216.650 6123.48
19300.0 216.650 6113.83
19310.0 216.650 6104.20
19320.0 216.650 6094.58
19330.0 216.650 6084.98
19340.0 216.650 6075.39
19350.0 216.650 6065.82
19360.0 216.650 6056.26
19370.0 216.650 6046.72
19380.0 216.650 6037.19
19390.0 216.650 6027.68
19400.0 216.650 6018.18
19410.0 216.650 6008.70
19420.0 216.650 5999.23
19430.0 216.650 5989.78
19440.0 216.650 5980.34
19450.0 216.650 5970.92
19460.0 216.650 5961.51
19470.0 216.650 5952.12
19480.0 216.650 5942.74
19490.0 216.650 5933.37
19500.0 216.650 5924.03
19510.0 216.650 5914.69
19520.0 216.650 5905.37
19530.0 216.650 5896.07
19540.0 216.650 5886.78
19550.0 216.650 5877.50
19560.0 216.650 5868.24
19570.0 216.650 5858.99
19580.0 216.650 5849.76
19590.0 216.650 5840.55
19600.0 216.650 5831.34
19610.0 216.650 5822.15
19620.0 216.650 5812.98
19630.0 216.650 5803.82
19640.0 216.650 5794.68
19650.0 216.650 5785.55
19660.0 216.650 5776.43
19670.0 216.650 5767.33
19680.0 216.650 5758.24
19690.0 216.650 5749.17
19700.0 216.650 5740.11
19710.0 216.650 5731.07
19720.0 216.650 5722.04
19730.0 216.650 5713.02
19740.0 216.650 5704.02
19750.0 216.650 5695.03
19760.0 216.650 5686.06
19770.0 216.650 5677.10
19780.0 216.650 5668.15
19790.0 216.650 5659.22
19800.0 216.650 5650.31
19810.0 216.650 5641.40
19820.0 216.650 5632.51
19830.0 216.650 5623.64
19840.0 216.650 5614.78
19850.0 216.650 5605.93
19860.0 216.650 5597.10
19870.0 216.650 5588.28
19880.0 216.650 5579.47
19890.0 216.650 5570.68
19900.0 216.650 5561.91
19910.0 216.650 5553.14
19920.0 216.650 5544.39
19930.0 216.650 5535.66
19940.0 216.650 5526.93
19950.0 216.650 5518.23
19960.0 216.650 5509.53
19970.0 216.650 5500.85
19980.0 216.650 5492.18
19990.0 216.650 5483.53
20000.0 216.650 5474.89
20010.0 216.660 5466.26
20020.0 216.670 5457.65
20030.0 216.680 5449.05
20040.0 216.690 5440.47
20050.0 216.700 5431.90
20060.0 216.710 5423.34
20070.0 216.720 5414.80
20080.0 216.730 5406.27
20090.0 216.740 5397.75
20100.0 216.750 5389.25
20110.0 216.760 5380.77
20120.0 216.770 5372.29
20130.0 216.780 5363.83
20140.0 216.790 5355.39
20150.0 216.800 5346.95
20160.0 216.810 5338.53
20170.0 216.820 5330.13
20180.0 216.830 5321.74
20190.0 216.840 5313.36
20200.0 216.850 5304.99
20210.0 216.860 5296.64
20220.0 216.870 5288.31
20230.0 216.880 5279.98
20240.0 216.890 5271.67
20250.0 216.900 5263.38
20260.0 216.910 5255.09
20270.0 216.920 5246.82
20280.0 216.930 5238.57
20290.0 216.940 5230.32
20300.0 216.950 5222.09
20310.0 216.960 5213.88
20320.0 216.970 5205.67
20330.0 216.980 5197.48
20340.0 216.990 5189.31
20350.0 217.000 5181.14
20360.0 217.010 5172.99
20370.0 217.020 5164.85
20380.0 217.030 5156.73
20390.0 217.040 5148.62
20400.0 217.050 5140.52
20410.0 217.060 5132.44
20420.0 217.070 5124.37
20430.0 217.080 5116.31
20440.0 217.090 5108.26
20450.0 217.100 5100.23
20460.0 217.110 5092.21
20470.0 217.120 5084.20
20480.0 217.130 5076.21
20490.0 217.140 5068.23
20500.0 217.150 5060.26
20510.0 217.160 5052.31
20520.0 217.170 5044.37
20530.0 217.180 5036.44
20540.0 217.190 5028.52
20550.0 217.200 5020.62
20560.0 217.210 5012.73
20570.0 217.220 5004.85
20580.0 217.230 4996.99
20590.0 217.240 4989.13
20600.0 217.250 4981.29
20610.0 217.260 4973.47
20620.0 217.270 4965.65
20630.0 217.280 4957.85
20640.0 217.290 4950.06
20650.0 217.300 4942.29
20660.0 217.310 4934.52
20670.0 217.320 4926.77
20680.0 217.330 4919.03
20690.0 217.340 4911.31
20700.0 217.350 4903.59
20710.0 217.360 4895.89
20720.0 217.370 4888.20
20730.0 217.380 4880.53
20740.0 217.390 4872.86
20750.0 217.400 4865.21
20760.0 217.410 4857.57
20770.0 217.420 4849.94
20780.0 217.430 4842.33
20790.0 217.440 4834.73
20800.0 217.450 4827.14
20810.0 217.460 4819.56
20820.0 217.470 4811.99
20830.0 217.480 4804.44
20840.0 217.490 4796.90
20850.0 217.500 4789.37
20860.0 217.510 4781.85
20870.0 217.520 4774.35
20880.0 217.530 4766.86
20890.0 217.540 4759.38
20900.0 217.550 4751.91
20910.0 217.560 4744.45
20920.0 217.570 4737.01
20930.0 217.580 4729.58
20940.0 217.590 4722.16
20950.0 217.600 4714.75
20960.0 217.610 4707.35
20970.0 217.620 4699.97
20980.0 217.630 4692.60
20990.0 217.640 4685.23
21000.0 217.650 4677.89
21010.0 217.660 4670.55
21020.0 217.670 4663.22
21030.0 217.680 4655.91
21040.0 217.690 4648.61
21050.0 217.700 4641.32
21060.0 217.710 4634.04
21070.0 217.720 4626.78
21080.0 217.730 4619.52
21090.0 217.740 4612.28
21100.0 217.750 4605.05
21110.0 217.760 4597.83
21120.0 217.770 4590.62
21130.0 217.780 4583.43
21140.0 217.790 4576.24
21150.0 217.800 4569.07
21160.0 217.810 4561.91
21170.0 217.820 4554.76
21180.0 217.830 4547.62
21190.0 217.840 4540.50
21200.0 217.850 4533.38
21210.0 217.860 4526.28
21220.0 217.870 4519.19
21230.0 217.880 4512.10
21240.0 217.890 4505.04
21250.0 217.900 4497.98
21260.0 217.910 4490.93
21270.0 217.920 4483.90
21280.0 217.930 4476.87
21290.0 217.940 4469.86
21300.0 217.950 4462.86
21310.0 217.960 4455.87
21320.0 217.970 4448.89
21330.0 217.980 4441.92
21340.0 217.990 4434.97
21350.0 218.000 4428.02
21360.0 218.010 4421.09
21370.0 218.020 4414.17
21380.0 218.030 4407.26
21390.0 218.040 4400.35
21400.0 218.050 4393.47
21410.0 218.060 4386.59
21420.0 218.070 4379.72
21430.0 218.080 4372.87
21440.0 218.090 4366.02
21450.0 218.100 4359.19
21460.0 218.110 4352.36
21470.0 218.120 4345.55
21480.0 218.130 4338.75
21490.0 218.140 4331.96
21500.0 218.150 4325.18
21510.0 218.160 4318.41
21520.0 218.170 4311.66
21530.0 218.180 4304.91
21540.0 218.190 4298.18
21550.0 218.200 4291.45
21560.0 218.210 4284.74
21570.0 218.220 4278.04
21580.0 218.230 4271.34
21590.0 218.240 4264.66
21600.0 218.250 4257.99
21610.0 218.260 4251.33
21620.0 218.270 4244.68
21630.0 218.280 4238.04
21640.0 218.290 4231.42
21650.0 218.300 4224.80
21660.0 218.310 4218.19
21670.0 218.320 4211.60
21680.0 218.330 4205.01
21690.0 218.340 4198.44
21700.0 218.350 4191.87
21710.0 218.360 4185.32
21720.0 218.370 4178.78
21730.0 218.380 4172.25
21740.0 218.390 4165.72
21750.0 218.400 4159.21
21760.0 218.410 4152.71
21770.0 218.420 4146.22
21780.0 218.430 4139.74
21790.0 218.440 4133.27
21800.0 218.450 4126.81
21810.0 218.460 4120.36
21820.0 218.470 4113.93
21830.0 218.480 4107.50
21840.0 218.490 4101.08
21850.0 218.500 4094.67
21860.0 218.510 4088.28
21870.0 218.520 4081.89
21880.0 218.530 4075.51
21890.0 218.540 4069.15
21900.0 218.550 4062.79
21910.0 218.560 4056.44
21920.0 218.570 4050.11
21930.0 218.580 4043.78
21940.0 218.590 4037.47
21950.0 218.600 4031.16
21960.0 218.610 4024.87
21970.0 218.620 4018.58
21980.0 218.630 4012.31
21990.0 218.640 4006.04
22000.0 218.650 3999.79
22010.0 218.660 3993.55
22020.0 218.670 3987.31
22030.0 218.680 3981.09
22040.0 218.690 3974.87
22050.0 218.700 3968.67
22060.0 218.710 3962.47
22070.0 218.720 3956.29
22080.0 218.730 3950.11
22090.0 218.740 3943.95
22100.0 218.750 3937.79
22110.0 218.760 3931.65
22120.0 218.770 3925.51
22130.0 218.780 3919.39
22140.0 218.790 3913.27
22150.0 218.800 3907.17
22160.0 218.810 3901.07
22170.0 218.820 3894.99
22180.0 218.830 3888.91
22190.0 218.840 3882.84
22200.0 218.850 3876.79
22210.0 218.860 3870.74
22220.0 218.870 3864.70
22230.0 218.880 3858.68
22240.0 218.890 3852.66
22250.0 218.900 3846.65
22260.0 218.910 3840.65
22270.0 218.920 3834.66
22280.0 218.930 3828.68
22290.0 218.940 3822.71
22300.0 218.950 3816.75
22310.0 218.960 3810.80
22320.0 218.970 3804.86
22330.0 218.980 3798.93
22340.0 218.990 3793.01
22350.0 219.000 3787.10
22360.0 219.010 3781.19
22370.0 219.020 3775.30
22380.0 219.030 3769.42
22390.0 219.040 3763.54
22400.0 219.050 3757.68
22410.0 219.060 3751.82
22420.0 219.070 3745.97
22430.0 219.080 3740.14
22440.0 219.090 3734.31
22450.0 219.100 3728.49
22460.0 219.110 3722.68
22470.0 219.120 3716.88
22480.0 219.130 3711.09
22490.0 219.140 3705.31
22500.0 219.150 3699.54
22510.0 219.160 3693.78
22520.0 219.170 3688.02
22530.0 219.180 3682.28
22540.0 219.190 3676.54
22550.0 219.200 3670.82
22560.0 219.210 3665.10
22570.0 219.220 3659.39
22580.0 219.230 3653.70
22590.0 219.240 3648.01
22600.0 219.250 3642.33
22610.0 219.260 3636.66
22620.0 219.270 3630.99
22630.0 219.280 3625.34
22640.0 219.290 3619.70
22650.0 219.300 3614.06
22660.0 219.310 3608.44
22670.0 219.320 3602.82
22680.0 219.330 3597.21
22690.0 219.340 3591.61
22700.0 219.350 3586.03
22710.0 219.360 3580.44
22720.0 219.370 3574.87
22730.0 219.380 3569.31
22740.0 219.390 3563.76
22750.0 219.400 3558.21
22760.0 219.410 3552.67
22770.0 219.420 3547.15
22780.0 219.430 3541.63
22790.0 219.440 3536.12
22800.0 219.450 3530.62
22810.0 219.460 3525.13
22820.0 219.470 3519.64
22830.0 219.480 3514.17
22840.0 219.490 3508.70
22850.0 219.500 3503.25
22860.0 219.510 3497.80
22870.0 219.520 3492.36
22880.0 219.530 3486.93
22890.0 219.540 3481.51
22900.0 219.550 3476.09
22910.0 219.560 3470.69
22920.0 219.570 3465.29
22930.0 219.580 3459.91
22940.0 219.590 3454.53
22950.0 219.600 3449.16
22960.0 219.610 3443.79
22970.0 219.620 3438.44
22980.0 219.630 3433.10
22990.0 219.640 3427.76
23000.0 219.650 3422.43
23010.0 219.660 3417.12
23020.0 219.670 3411.81
23030.0 219.680 3406.50
23040.0 219.690 3401.21
23050.0 219.700 3395.93
23060.0 219.710 3390.65
23070.0 219.720 3385.38
23080.0 219.730 3380.12
23090.0 219.740 3374.87
23100.0 219.750 3369.63
23110.0 219.760 3364.39
23120.0 219.770 3359.17
23130.0 219.780 3353.95
23140.0 219.790 3348.74
23150.0 219.800 3343.54
23160.0 219.810 3338.35
23170.0 219.820 3333.16
23180.0 219.830 3327.99
23190.0 219.840 3322.82
23200.0 219.850 3317.66
23210.0 219.860 3312.51
23220.0 219.870 3307.36
23230.0 219.880 3302.23
23240.0 219.890 3297.10
23250.0 219.900 3291.98
23260.0 219.910 3286.87
23270.0 219.920 3281.77
23280.0 219.930 3276.68
23290.0 219.940 3271.59
23300.0 219.950 3266.51
23310.0 219.960 3261.44
23320.0 219.970 3256.38
23330.0 219.980 3251.33
23340.0 219.990 3246.28
23350.0 220.000 3241.25
23360.0 220.010 3236.22
23370.0 220.020 3231.20
23380.0 220.030 3226.18
23390.0 220.040 3221.18
23400.0 220.050 3216.18
23410.0 220.060 3211.19
23420.0 220.070 3206.21
23430.0 220.080 3201.24
23440.0 220.090 3196.27
23450.0 220.100 3191.32
23460.0 220.110 3186.37
23470.0 220.120 3181.42
23480.0 220.130 3176.49
23490.0 220.140 3171.56
23500.0 220.150 3166.65
23510.0 220.160 3161.74
23520.0 220.170 3156.83
23530.0 220.180 3151.94
23540.0 220.190 3147.05
23550.0 220.200 3142.17
23560.0 220.210 3137.30
23570.0 220.220 3132.44
23580.0 220.230 3127.58
23590.0 220.240 3122.74
23600.0 220.250 3117.90
23610.0 220.260 3113.06
23620.0 220.270 3108.24
23630.0 220.280 3103.42
23640.0 220.290 3098.61
23650.0 220.300 3093.81
23660.0 220.310 3089.02
23670.0 220.320 3084.23
23680.0 220.330 3079.45
23690.0 220.340 3074.68
23700.0 220.350 3069.92
23710.0 220.360 3065.16
23720.0 220.370 3060.41
23730.0 220.380 3055.67
23740.0 220.390 3050.94
23750.0 220.400 3046.21
23760.0 220.410 3041.50
23770.0 220.420 3036.79
23780.0 220.430 3032.08
23790.0 220.440 3027.39
23800.0 220.450 3022.70
23810.0 220.460 3018.02
23820.0 220.470 3013.35
23830.0 220.480 3008.68
23840.0 220.490 3004.02
23850.0 220.500 2999.37
23860.0 220.510 2994.73
23870.0 220.520 2990.09
23880.0 220.530 2985.46
23890.0 220.540 2980.84
23900.0 220.550 2976.23
23910.0 220.560 2971.62
23920.0 220.570 2967.02
23930.0 220.580 2962.43
23940.0 220.590 2957.85
23950.0 220.600 2953.27
23960.0 220.610 2948.70
23970.0 220.620 2944.14
23980.0 220.630 2939.58
23990.0 220.640 2935.03
24000.0 220.650 2930.49
24010.0 220.660 2925.96
24020.0 220.670 2921.43
24030.0 220.680 2916.91
24040.0 220.690 2912.40
24050.0 220.700 2907.90
24060.0 220.710 2903.40
24070.0 220.720 2898.91
24080.0 220.730 2894.42
24090.0 220.740 2889.95
24100.0 220.750 2885.48
24110.0 220.760 2881.02
24120.0 220.770 2876.56
24130.0 220.780 2872.11
24140.0 220.790 2867.67
24150.0 220.800 2863.24
24160.0 220.810 2858.81
24170.0 220.820 2854.39
24180.0 220.830 2849.98
24190.0 220.840 2845.58
24200.0 220.850 2841.18
24210.0 220.860 2836.79
24220.0 220.870 2832.40
24230.0 220.880 2828.02
24240.0 220.890 2823.65
24250.0 220.900 2819.29
24260.0 220.910 2814.93
24270.0 220.920 2810.58
24280.0 220.930 2806.24
24290.0 220.940 2801.90
24300.0 220.950 2797.58
24310.0 220.960 2793.25
24320.0 220.970 2788.94
24330.0 220.980 2784.63
24340.0 220.990 2780.33
24350.0 221.000 2776.03
24360.0 221.010 2771.74
24370.0 221.020 2767.46
24380.0 221.030 2763.19
24390.0 221.040 2758.92
24400.0 221.050 2754.66
24410.0 221.060 2750.41
24420.0 221.070 2746.16
24430.0 221.080 2741.92
24440.0 221.090 2737.69
24450.0 221.100 2733.46
24460.0 221.110 2729.24
24470.0 221.120 2725.03
24480.0 221.130 2720.82
24490.0 221.140 2716.62
24500.0 221.150 2712.42
24510.0 221.160 2708.24
24520.0 221.170 2704.06
24530.0 221.180 2699.88
24540.0 221.190 2695.72
24550.0 221.200 2691.56
24560.0 221.210 2687.40
24570.0 221.220 2683.26
24580.0 221.230 2679.12
24590.0 221.240 2674.98
24600.0 221.250 2670.85
24610.0 221.260 2666.73
24620.0 221.270 2662.62
24630.0 221.280 2658.51
24640.0 221.290 2654.41
24650.0 221.300 2650.32
24660.0 221.310 2646.23
24670.0 221.320 2642.15
24680.0 221.330 2638.07
24690.0 221.340 2634.00
24700.0 221.350 2629.94
24710.0 221.360 2625.88
24720.0 221.370 2621.83
24730.0 221.380 2617.79
24740.0 221.390 2613.76
24750.0 221.400 2609.73
24760.0 221.410 2605.70
24770.0 221.420 2601.68
24780.0 221.430 2597.67
24790.0 221.440 2593.67
24800.0 221.450 2589.67
24810.0 221.460 2585.68
24820.0 221.470 2581.69
24830.0 221.480 2577.71
24840.0 221.490 2573.74
24850.0 221.500 2569.77
24860.0 221.510 2565.81
24870.0 221.520 2561.86
24880.0 221.530 2557.91
24890.0 221.540 2553.97
24900.0 221.550 2550.03
24910.0 221.560 2546.11
24920.0 221.570 2542.18
24930.0 221.580 2538.27
24940.0 221.590 2534.36
24950.0 221.600 2530.45
24960.0 221.610 2526.55
24970.0 221.620 2522.66
24980.0 221.630 2518.78
24990.0 221.640 2514.90
25000.0 221.650 2511.02
25010.0 221.660 2507.16
25020.0 221.670 2503.30
25030.0 221.680 2499.44
25040.0 221.690 2495.59
25050.0 221.700 2491.75
25060.0 221.710 2487.91
25070.0 221.720 2484.08
25080.0 221.730 2480.26
25090.0 221.740 2476.44
25100.0 221.750 2472.63
25110.0 221.760 2468.82
25120.0 221.770 2465.02
25130.0 221.780 2461.22
25140.0 221.790 2457.44
25150.0 221.800 2453.65
25160.0 221.810 2449.88
25170.0 221.820 2446.11
25180.0 221.830 2442.34
25190.0 221.840 2438.59
25200.0 221.850 2434.83
25210.0 221.860 2431.09
25220.0 221.870 2427.35
25230.0 221.880 2423.61
25240.0 221.890 2419.88
25250.0 221.900 2416.16
25260.0 221.910 2412.44
25270.0 221.920 2408.73
25280.0 221.930 2405.03
25290.0 221.940 2401.33
25300.0 221.950 2397.63
25310.0 221.960 2393.95
25320.0 221.970 2390.26
25330.0 221.980 2386.59
25340.0 221.990 2382.92
25350.0 222.000 2379.25
25360.0 222.010 2375.60
25370.0 222.020 2371.94
25380.0 222.030 2368.30
25390.0 222.040 2364.65
25400.0 222.050 2361.02
25410.0 222.060 2357.39
25420.0 222.070 2353.77
25430.0 222.080 2350.15
25440.0 222.090 2346.54
25450.0 222.100 2342.93
25460.0 222.110 2339.33
25470.0 222.120 2335.73
25480.0 222.130 2332.14
25490.0 222.140 2328.56
25500.0 222.150 2324.98
25510.0 222.160 2321.41
25520.0 222.170 2317.84
25530.0 222.180 2314.28
25540.0 222.190 2310.72
25550.0 222.200 2307.17
25560.0 222.210 2303.63
25570.0 222.220 2300.09
25580.0 222.230 2296.56
25590.0 222.240 2293.03
25600.0 222.250 2289.51
25610.0 222.260 2285.99
25620.0 222.270 2282.48
25630.0 222.280 2278.97
25640.0 222.290 2275.47
25650.0 222.300 2271.98
25660.0 222.310 2268.49
25670.0 222.320 2265.01
25680.0 222.330 2261.53
25690.0 222.340 2258.06
25700.0 222.350 2254.59
25710.0 222.360 2251.13
25720.0 222.370 2247.67
25730.0 222.380 2244.22
25740.0 222.390 2240.78
25750.0 222.400 2237.34
25760.0 222.410 2233.90
25770.0 222.420 2230.48
25780.0 222.430 2227.05
25790.0 222.440 2223.63
25800.0 222.450 2220.22
25810.0 222.460 2216.82
25820.0 222.470 2213.41
25830.0 222.480 2210.02
25840.0 222.490 2206.63
25850.0 222.500 2203.24
25860.0 222.510 2199.86
25870.0 222.520 2196.49
25880.0 222.530 2193.12
25890.0 222.540 2189.75
25900.0 222.550 2186.39
25910.0 222.560 2183.04
25920.0 222.570 2179.69
25930.0 222.580 2176.35
25940.0 222.590 2173.01
25950.0 222.600 2169.68
25960.0 222.610 2166.35
25970.0 222.620 2163.03
25980.0 222.630 2159.71
25990.0 222.640 2156.40
26000.0 222.650 2153.09
26010.0 222.660 2149.79
26020.0 222.670 2146.50
26030.0 222.680 2143.21
26040.0 222.690 2139.92
26050.0 222.700 2136.64
26060.0 222.710 2133.37
26070.0 222.720 2130.10
26080.0 222.730 2126.83
26090.0 222.740 2123.57
26100.0 222.750 2120.32
26110.0 222.760 2117.07
26120.0 222.770 2113.82
26130.0 222.780 2110.58
26140.0 222.790 2107.35
26150.0 222.800 2104.12
26160.0 222.810 2100.90
26170.0 222.820 2097.68
26180.0 222.830 2094.46
26190.0 222.840 2091.26
26200.0 222.850 2088.05
26210.0 222.860 2084.85
26220.0 222.870 2081.66
26230.0 222.880 2078.47
26240.0 222.890 2075.29
26250.0 222.900 2072.11
26260.0 222.910 2068.94
26270.0 222.920 2065.77
26280.0 222.930 2062.61
26290.0 222.940 2059.45
26300.0 222.950 2056.29
26310.0 222.960 2053.14
26320.0 222.970 2050.00
26330.0 222.980 2046.86
26340.0 222.990 2043.73
26350.0 223.000 2040.60
26360.0 223.010 2037.48
26370.0 223.020 2034.36
26380.0 223.030 2031.24
26390.0 223.040 2028.14
26400.0 223.050 2025.03
26410.0 223.060 2021.93
26420.0 223.070 2018.84
26430.0 223.080 2015.75
26440.0 223.090 2012.66
26450.0 223.100 2009.58
26460.0 223.110 2006.51
26470.0 223.120 2003.44
26480.0 223.130 2000.37
26490.0 223.140 1997.31
26500.0 223.150 1994.26
26510.0 223.160 1991.21
26520.0 223.170 1988.16
26530.0 223.180 1985.12
26540.0 223.190 1982.08
26550.0 223.200 1979.05
26560.0 223.210 1976.03
26570.0 223.220 1973.00
26580.0 223.230 1969.99
26590.0 223.240 1966.97
26600.0 223.250 1963.97
26610.0 223.260 1960.96
26620.0 223.270 1957.97
26630.0 223.280 1954.97
26640.0 223.290 1951.98
26650.0 223.300 1949.00
26660.0 223.310 1946.02
26670.0 223.320 1943.04
26680.0 223.330 1940.07
26690.0 223.340 1937.11
26700.0 223.350 1934.15
26710.0 223.360 1931.19
26720.0 223.370 1928.24
26730.0 223.380 1925.29
26740.0 223.390 1922.35
26750.0 223.400 1919.41
26760.0 223.410 1916.48
26770.0 223.420 1913.55
26780.0 223.430 1910.63
26790.0 223.440 1907.71
26800.0 223.450 1904.80
26810.0 223.460 1901.89
26820.0 223.470 1898.98
26830.0 223.480 1896.08
26840.0 223.490 1893.18
26850.0 223.500 1890.29
26860.0 223.510 1887.40
26870.0 223.520 1884.52
26880.0 223.530 1881.64
26890.0 223.540 1878.77
26900.0 223.550 1875.90
26910.0 223.560 1873.04
26920.0 223.570 1870.18
26930.0 223.580 1867.32
26940.0 223.590 1864.47
26950.0 223.600 1861.62
26960.0 223.610 1858.78
26970.0 223.620 1855.94
26980.0 223.630 1853.11
26990.0 223.640 1850.28
27000.0 223.650 1847.46
27010.0 223.660 1844.64
27020.0 223.670 1841.82
27030.0 223.680 1839.01
27040.0 223.690 1836.20
27050.0 223.700 1833.40
27060.0 223.710 1830.60
27070.0 223.720 1827.81
27080.0 223.730 1825.02
27090.0 223.740 1822.24
27100.0 223.750 1819.46
27110.0 223.760 1816.68
27120.0 223.770 1813.91
27130.0 223.780 1811.14
27140.0 223.790 1808.38
27150.0 223.800 1805.62
27160.0 223.810 1802.87
27170.0 223.820 1800.12
27180.0 223.830 1797.37
27190.0 223.840 1794.63
27200.0 223.850 1791.89
27210.0 223.860 1789.16
27220.0 223.870 1786.43
27230.0 223.880 1783.71
27240.0 223.890 1780.99
27250.0 223.900 1778.27
27260.0 223.910 1775.56
27270.0 223.920 1772.86
27280.0 223.930 1770.15
27290.0 223.940 1767.45
27300.0 223.950 1764.76
27310.0 223.960 1762.07
27320.0 223.970 1759.38
27330.0 223.980 1756.70
27340.0 223.990 1754.03
27350.0 224.000 1751.35
27360.0 224.010 1748.68
27370.0 224.020 1746.02
27380.0 224.030 1743.36
27390.0 224.040 1740.70
27400.0 224.050 1738.05
27410.0 224.060 1735.40
27420.0 224.070 1732.76
27430.0 224.080 1730.12
27440.0 224.090 1727.48
27450.0 224.100 1724.85
27460.0 224.110 1722.22
27470.0 224.120 1719.60
27480.0 224.130 1716.98
27490.0 224.140 1714.37
27500.0 224.150 1711.75
27510.0 224.160 1709.15
27520.0 224.170 1706.55
27530.0 224.180 1703.95
27540.0 224.190 1701.35
27550.0 224.200 1698.76
27560.0 224.210 1696.17
27570.0 224.220 1693.59
27580.0 224.230 1691.01
27590.0 224.240 1688.44
27600.0 224.250 1685.87
27610.0 224.260 1683.30
27620.0 224.270 1680.74
27630.0 224.280 1678.18
27640.0 224.290 1675.63
27650.0 224.300 1673.08
27660.0 224.310 1670.53
27670.0 224.320 1667.99
27680.0 224.330 1665.45
27690.0 224.340 1662.92
27700.0 224.350 1660.39
27710.0 224.360 1657.86
27720.0 224.370 1655.34
27730.0 224.380 1652.82
27740.0 224.390 1650.30
27750.0 224.400 1647.79
27760.0 224.410 1645.29
27770.0 224.420 1642.78
27780.0 224.430 1640.29
27790.0 224.440 1637.79
27800.0 224.450 1635.30
27810.0 224.460 1632.81
27820.0 224.470 1630.33
27830.0 224.480 1627.85
27840.0 224.490 1625.37
27850.0 224.500 1622.90
27860.0 224.510 1620.44
27870.0 224.520 1617.97
27880.0 224.530 1615.51
27890.0 224.540 1613.06
27900.0 224.550 1610.60
27910.0 224.560 1608.15
27920.0 224.570 1605.71
27930.0 224.580 1603.27
27940.0 224.590 1600.83
27950.0 224.600 1598.40
27960.0 224.610 1595.97
27970.0 224.620 1593.54
27980.0 224.630 1591.12
27990.0 224.640 1588.70
28000.0 224.650 1586.29
28010.0 224.660 1583.88
28020.0 224.670 1581.47
28030.0 224.680 1579.07
28040.0 224.690 1576.67
28050.0 224.700 1574.28
28060.0 224.710 1571.88
28070.0 224.720 1569.50
28080.0 224.730 1567.11
28090.0 224.740 1564.73
28100.0 224.750 1562.35
28110.0 224.760 1559.98
28120.0 224.770 1557.61
28130.0 224.780 1555.25
28140.0 224.790 1552.88
28150.0 224.800 1550.53
28160.0 224.810 1548.17
28170.0 224.820 1545.82
28180.0 224.830 1543.47
28190.0 224.840 1541.13
28200.0 224.850 1538.79
28210.0 224.860 1536.45
28220.0 224.870 1534.12
28230.0 224.880 1531.79
28240.0 224.890 1529.47
28250.0 224.900 1527.15
28260.0 224.910 1524.83
28270.0 224.920 1522.51
28280.0 224.930 1520.20
28290.0 224.940 1517.90
28300.0 224.950 1515.59
28310.0 224.960 1513.29
28320.0 224.970 1511.00
28330.0 224.980 1508.70
28340.0 224.990 1506.41
28350.0 225.000 1504.13
28360.0 225.010 1501.85
28370.0 225.020 1499.57
28380.0 225.030 1497.29
28390.0 225.040 1495.02
28400.0 225.050 1492.75
28410.0 225.060 1490.49
28420.0 225.070 1488.23
28430.0 225.080 1485.97
28440.0 225.090 1483.72
28450.0 225.100 1481.47
28460.0 225.110 1479.22
28470.0 225.120 1476.98
28480.0 225.130 1474.74
28490.0 225.140 1472.50
28500.0 225.150 1470.27
28510.0 225.160 1468.04
28520.0 225.170 1465.81
28530.0 225.180 1463.59
28540.0 225.190 1461.37
28550.0 225.200 1459.16
28560.0 225.210 1456.95
28570.0 225.220 1454.74
28580.0 225.230 1452.53
28590.0 225.240 1450.33
28600.0 225.250 1448.13
28610.0 225.260 1445.94
28620.0 225.270 1443.75
28630.0 225.280 1441.56
28640.0 225.290 1439.38
28650.0 225.300 1437.19
28660.0 225.310 1435.02
28670.0 225.320 1432.84
28680.0 225.330 1430.67
28690.0 225.340 1428.50
28700.0 225.350 1426.34
28710.0 225.360 1424.18
28720.0 225.370 1422.02
28730.0 225.380 1419.87
28740.0 225.390 1417.72
28750.0 225.400 1415.57
28760.0 225.410 1413.43
28770.0 225.420 1411.29
28780.0 225.430 1409.15
28790.0 225.440 1407.02
28800.0 225.450 1404.89
28810.0 225.460 1402.76
28820.0 225.470 1400.63
28830.0 225.480 1398.51
28840.0 225.490 1396.40
28850.0 225.500 1394.28
28860.0 225.510 1392.17
28870.0 225.520 1390.06
28880.0 225.530 1387.96
28890.0 225.540 1385.86
28900.0 225.550 1383.76
28910.0 225.560 1381.67
28920.0 225.570 1379.58
28930.0 225.580 1377.49
28940.0 225.590 1375.40
28950.0 225.600 1373.32
28960.0 225.610 1371.24
28970.0 225.620 1369.17
28980.0 225.630 1367.10
28990.0 225.640 1365.03
29000.0 225.650 1362.96
29010.0 225.660 1360.90
29020.0 225.670 1358.84
29030.0 225.680 1356.79
29040.0 225.690 1354.74
29050.0 225.700 1352.69
29060.0 225.710 1350.64
29070.0 225.720 1348.60
29080.0 225.730 1346.56
29090.0 225.740 1344.52
29100.0 225.750 1342.49
29110.0 225.760 1340.46
29120.0 225.770 1338.43
29130.0 225.780 1336.41
29140.0 225.790 1334.39
29150.0 225.800 1332.37
29160.0 225.810 1330.36
29170.0 225.820 1328.35
29180.0 225.830 1326.34
29190.0 225.840 1324.33
29200.0 225.850 1322.33
29210.0 225.860 1320.33
29220.0 225.870 1318.34
29230.0 225.880 1316.34
29240.0 225.890 1314.35
29250.0 225.900 1312.37
29260.0 225.910 1310.39
29270.0 225.920 1308.41
29280.0 225.930 1306.43
29290.0 225.940 1304.45
29300.0 225.950 1302.48
29310.0 225.960 1300.52
29320.0 225.970 1298.55
29330.0 225.980 1296.59
29340.0 225.990 1294.63
29350.0 226.000 1292.68
29360.0 226.010 1290.72
29370.0 226.020 1288.77
29380.0 226.030 1286.83
29390.0 226.040 1284.88
29400.0 226.050 1282.94
29410.0 226.060 1281.01
29420.0 226.070 1279.07
29430.0 226.080 1277.14
29440.0 226.090 1275.21
29450.0 226.100 1273.29
29460.0 226.110 1271.36
29470.0 226.120 1269.44
29480.0 226.130 1267.53
29490.0 226.140 1265.61
29500.0 226.150 1263.70
29510.0 226.160 1261.80
29520.0 226.170 1259.89
29530.0 226.180 1257.99
29540.0 226.190 1256.09
29550.0 226.200 1254.20
29560.0 226.210 1252.30
29570.0 226.220 1250.41
29580.0 226.230 1248.53
29590.0 226.240 1246.64
29600.0 226.250 1244.76
29610.0 226.260 1242.88
29620.0 226.270 1241.01
29630.0 226.280 1239.14
29640.0 226.290 1237.27
29650.0 226.300 1235.40
29660.0 226.310 1233.54
29670.0 226.320 1231.68
29680.0 226.330 1229.82
29690.0 226.340 1227.96
29700.0 226.350 1226.11
29710.0 226.360 1224.26
29720.0 226.370 1222.42
29730.0 226.380 1220.57
29740.0 226.390 1218.73
29750.0 226.400 1216.89
29760.0 226.410 1215.06
29770.0 226.420 1213.23
29780.0 226.430 1211.40
29790.0 226.440 1209.57
29800.0 226.450 1207.75
29810.0 226.460 1205.93
29820.0 226.470 1204.11
29830.0 226.480 1202.29
29840.0 226.490 1200.48
29850.0 226.500 1198.67
29860.0 226.510 1196.87
29870.0 226.520 1195.06
29880.0 226.530 1193.26
29890.0 226.540 1191.46
29900.0 226.550 1189.67
29910.0 226.560 1187.88
29920.0 226.570 1186.09
29930.0 226.580 1184.30
29940.0 226.590 1182.51
29950.0 226.600 1180.73
29960.0 226.610 1178.95
29970.0 226.620 1177.18
29980.0 226.630 1175.40
29990.0 226.640 1173.63
30000.0 226.650 1171.87

/tags/1.0/goodies/reformat.sh
0,0 → 1,32
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp reformat short
echo
exit 0
endif
set inpfile=$1
set outfile=$2
set prog1=${LAGRANTO}/goodies/reformat
set prog2=${LAGRANTO}/goodies/trainfo.sh
set dim=`${prog2} ${inpfile} dim`
\rm -f reformat.param
echo \"${inpfile}\" >! reformat.param
echo \"${outfile}\" >> reformat.param
echo ${dim} >> reformat.param
${prog1}
\rm -f reformat.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/stringmod.f90
0,0 → 1,785
module strings
use precision
private :: value_dr,value_sr,value_di,value_si
private :: write_dr,write_sr,write_di,write_si
private :: writeq_dr,writeq_sr,writeq_di,writeq_si
interface value ! Generic operator for converting a number string to a
! number. Calling syntax is 'call value(numstring,number,ios)'
! where 'numstring' is a number string and 'number' is a
! real number or an integer (single or double precision).
module procedure value_dr
module procedure value_sr
module procedure value_di
module procedure value_si
end interface
interface writenum ! Generic interface for writing a number to a string. The
! number is left justified in the string. The calling syntax
! is 'call writenum(number,string,format)' where 'number' is
! a real number or an integer, 'string' is a character string
! containing the result, and 'format' is the format desired,
! e.g., 'e15.6' or 'i5'.
module procedure write_dr
module procedure write_sr
module procedure write_di
module procedure write_si
end interface
interface writeq ! Generic interface equating a name to a numerical value. The
! calling syntax is 'call writeq(unit,name,value,format)' where
! unit is the integer output unit number, 'name' is the variable
! name, 'value' is the real or integer value of the variable,
! and 'format' is the format of the value. The result written to
! the output unit has the form <name> = <value>.
module procedure writeq_dr
module procedure writeq_sr
module procedure writeq_di
module procedure writeq_si
end interface
!**********************************************************************
contains
!**********************************************************************
subroutine parse(str,delims,args,nargs)
! Parses the string 'str' into arguments args(1), ..., args(nargs) based on
! the delimiters contained in the string 'delims'. Preceding a delimiter in
! 'str' by a backslash (\) makes this particular instance not a delimiter.
! The integer output variable nargs contains the number of arguments found.
character(len=*) :: str,delims
character(len=len_trim(str)) :: strsav
character(len=*),dimension(:) :: args
strsav=str
call compact(str)
na=size(args)
do i=1,na
args(i)=' '
end do
nargs=0
lenstr=len_trim(str)
if(lenstr==0) return
k=0
do
if(len_trim(str) == 0) exit
nargs=nargs+1
call split(str,delims,args(nargs))
call removebksl(args(nargs))
end do
str=strsav
end subroutine parse
!**********************************************************************
subroutine compact(str)
! Converts multiple spaces and tabs to single spaces; deletes control characters;
! removes initial spaces.
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str)):: outstr
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
isp=0
k=0
do i=1,lenstr
ch=str(i:i)
ich=iachar(ch)
select case(ich)
case(9,32) ! space or tab character
if(isp==0) then
k=k+1
outstr(k:k)=' '
end if
isp=1
case(33:) ! not a space, quote, or control character
k=k+1
outstr(k:k)=ch
isp=0
end select
end do
str=adjustl(outstr)
end subroutine compact
!**********************************************************************
subroutine removesp(str)
! Removes spaces, tabs, and control characters in string str
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str))::outstr
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
k=0
do i=1,lenstr
ch=str(i:i)
ich=iachar(ch)
select case(ich)
case(0:32) ! space, tab, or control character
cycle
case(33:)
k=k+1
outstr(k:k)=ch
end select
end do
str=adjustl(outstr)
end subroutine removesp
!**********************************************************************
subroutine value_dr(str,rnum,ios)
! Converts number string to a double precision real number
character(len=*)::str
real(kr8)::rnum
integer :: ios
ilen=len_trim(str)
ipos=scan(str,'Ee')
if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then
ios=3
return
end if
read(str,*,iostat=ios) rnum
end subroutine value_dr
!**********************************************************************
subroutine value_sr(str,rnum,ios)
! Converts number string to a single precision real number
character(len=*)::str
real(kr4) :: rnum
real(kr8) :: rnumd
call value_dr(str,rnumd,ios)
if( abs(rnumd) > huge(rnum) ) then
ios=15
return
end if
if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4
rnum=rnumd
end subroutine value_sr
!**********************************************************************
subroutine value_di(str,inum,ios)
! Converts number string to a double precision integer value
character(len=*)::str
integer(ki8) :: inum
real(kr8) :: rnum
call value_dr(str,rnum,ios)
if(abs(rnum)>huge(inum)) then
ios=15
return
end if
inum=nint(rnum,ki8)
end subroutine value_di
!**********************************************************************
subroutine value_si(str,inum,ios)
! Converts number string to a single precision integer value
character(len=*)::str
integer(ki4) :: inum
real(kr8) :: rnum
call value_dr(str,rnum,ios)
if(abs(rnum)>huge(inum)) then
ios=15
return
end if
inum=nint(rnum,ki4)
end subroutine value_si
!**********************************************************************
subroutine shiftstr(str,n)
! Shifts characters in in the string 'str' n positions (positive values
! denote a right shift and negative values denote a left shift). Characters
! that are shifted off the end are lost. Positions opened up by the shift
! are replaced by spaces.
character(len=*):: str
lenstr=len(str)
nabs=iabs(n)
if(nabs>=lenstr) then
str=repeat(' ',lenstr)
return
end if
if(n<0) str=str(nabs+1:)//repeat(' ',nabs) ! shift left
if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs) ! shift right
return
end subroutine shiftstr
!**********************************************************************
subroutine insertstr(str,strins,loc)
! Inserts the string 'strins' into the string 'str' at position 'loc'.
! Characters in 'str' starting at position 'loc' are shifted right to
! make room for the inserted string. Trailing spaces of 'strins' are
! removed prior to insertion
character(len=*):: str,strins
character(len=len(str))::tempstr
lenstrins=len_trim(strins)
tempstr=str(loc:)
call shiftstr(tempstr,lenstrins)
tempstr(1:lenstrins)=strins(1:lenstrins)
str(loc:)=tempstr
return
end subroutine insertstr
!**********************************************************************
subroutine delsubstr(str,substr)
! Deletes first occurrence of substring 'substr' from string 'str' and
! shifts characters left to fill hole. Trailing spaces or blanks are
! not considered part of 'substr'.
character(len=*):: str,substr
lensubstr=len_trim(substr)
ipos=index(str,substr)
if(ipos==0) return
if(ipos == 1) then
str=str(lensubstr+1:)
else
str=str(:ipos-1)//str(ipos+lensubstr:)
end if
return
end subroutine delsubstr
!**********************************************************************
subroutine delall(str,substr)
! Deletes all occurrences of substring 'substr' from string 'str' and
! shifts characters left to fill holes.
character(len=*):: str,substr
lensubstr=len_trim(substr)
do
ipos=index(str,substr)
if(ipos == 0) exit
if(ipos == 1) then
str=str(lensubstr+1:)
else
str=str(:ipos-1)//str(ipos+lensubstr:)
end if
end do
return
end subroutine delall
!**********************************************************************
function uppercase(str) result(ucstr)
! convert string to upper case
character (len=*):: str
character (len=len_trim(str)):: ucstr
ilen=len_trim(str)
ioffset=iachar('A')-iachar('a')
iquote=0
ucstr=str
do i=1,ilen
iav=iachar(str(i:i))
if(iquote==0 .and. (iav==34 .or.iav==39)) then
iquote=1
iqc=iav
cycle
end if
if(iquote==1 .and. iav==iqc) then
iquote=0
cycle
end if
if (iquote==1) cycle
if(iav >= iachar('a') .and. iav <= iachar('z')) then
ucstr(i:i)=achar(iav+ioffset)
else
ucstr(i:i)=str(i:i)
end if
end do
return
end function uppercase
!**********************************************************************
function lowercase(str) result(lcstr)
! convert string to lower case
character (len=*):: str
character (len=len_trim(str)):: lcstr
ilen=len_trim(str)
ioffset=iachar('A')-iachar('a')
iquote=0
lcstr=str
do i=1,ilen
iav=iachar(str(i:i))
if(iquote==0 .and. (iav==34 .or.iav==39)) then
iquote=1
iqc=iav
cycle
end if
if(iquote==1 .and. iav==iqc) then
iquote=0
cycle
end if
if (iquote==1) cycle
if(iav >= iachar('A') .and. iav <= iachar('Z')) then
lcstr(i:i)=achar(iav-ioffset)
else
lcstr(i:i)=str(i:i)
end if
end do
return
end function lowercase
!**********************************************************************
subroutine readline(nunitr,line,ios)
! Reads line from unit=nunitr, ignoring blank lines
! and deleting comments beginning with an exclamation point(!)
character (len=*):: line
do
read(nunitr,'(a)', iostat=ios) line ! read input line
if(ios /= 0) return
line=adjustl(line)
ipos=index(line,'!')
if(ipos == 1) cycle
if(ipos /= 0) line=line(:ipos-1)
if(len_trim(line) /= 0) exit
end do
return
end subroutine readline
!**********************************************************************
subroutine match(str,ipos,imatch)
! Sets imatch to the position in string of the delimiter matching the delimiter
! in position ipos. Allowable delimiters are (), [], {}, <>.
character(len=*) :: str
character :: delim1,delim2,ch
lenstr=len_trim(str)
delim1=str(ipos:ipos)
select case(delim1)
case('(')
idelim2=iachar(delim1)+1
istart=ipos+1
iend=lenstr
inc=1
case(')')
idelim2=iachar(delim1)-1
istart=ipos-1
iend=1
inc=-1
case('[','{','<')
idelim2=iachar(delim1)+2
istart=ipos+1
iend=lenstr
inc=1
case(']','}','>')
idelim2=iachar(delim1)-2
istart=ipos-1
iend=1
inc=-1
case default
write(*,*) delim1,' is not a valid delimiter'
return
end select
if(istart < 1 .or. istart > lenstr) then
write(*,*) delim1,' has no matching delimiter'
return
end if
delim2=achar(idelim2) ! matching delimiter
isum=1
do i=istart,iend,inc
ch=str(i:i)
if(ch /= delim1 .and. ch /= delim2) cycle
if(ch == delim1) isum=isum+1
if(ch == delim2) isum=isum-1
if(isum == 0) exit
end do
if(isum /= 0) then
write(*,*) delim1,' has no matching delimiter'
return
end if
imatch=i
return
end subroutine match
!**********************************************************************
subroutine write_dr(rnum,str,fmt)
! Writes double precision real number rnum to string str using format fmt
real(kr8) :: rnum
character(len=*) :: str,fmt
character(len=80) :: formt
formt='('//trim(fmt)//')'
write(str,formt) rnum
str=adjustl(str)
end subroutine write_dr
!***********************************************************************
subroutine write_sr(rnum,str,fmt)
! Writes single precision real number rnum to string str using format fmt
real(kr4) :: rnum
character(len=*) :: str,fmt
character(len=80) :: formt
formt='('//trim(fmt)//')'
write(str,formt) rnum
str=adjustl(str)
end subroutine write_sr
!***********************************************************************
subroutine write_di(inum,str,fmt)
! Writes double precision integer inum to string str using format fmt
integer(ki8) :: inum
character(len=*) :: str,fmt
character(len=80) :: formt
formt='('//trim(fmt)//')'
write(str,formt) inum
str=adjustl(str)
end subroutine write_di
!***********************************************************************
subroutine write_si(inum,str,fmt)
! Writes single precision integer inum to string str using format fmt
integer(ki4) :: inum
character(len=*) :: str,fmt
character(len=80) :: formt
formt='('//trim(fmt)//')'
write(str,formt) inum
str=adjustl(str)
end subroutine write_si
!***********************************************************************
subroutine trimzero(str)
! Deletes nonsignificant trailing zeroes from number string str. If number
! string ends in a decimal point, one trailing zero is added.
character(len=*) :: str
character :: ch
character(len=10) :: exp
ipos=scan(str,'eE')
if(ipos>0) then
exp=str(ipos:)
str=str(1:ipos-1)
endif
lstr=len_trim(str)
do i=lstr,1,-1
ch=str(i:i)
if(ch=='0') cycle
if(ch=='.') then
str=str(1:i)//'0'
if(ipos>0) str=trim(str)//trim(exp)
exit
endif
str=str(1:i)
exit
end do
if(ipos>0) str=trim(str)//trim(exp)
end subroutine trimzero
!**********************************************************************
subroutine writeq_dr(unit,namestr,value,fmt)
! Writes a string of the form <name> = value to unit
real(kr8) :: value
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(value,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
end subroutine writeq_dr
!**********************************************************************
subroutine writeq_sr(unit,namestr,value,fmt)
! Writes a string of the form <name> = value to unit
real(kr4) :: value
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(value,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
end subroutine writeq_sr
!**********************************************************************
subroutine writeq_di(unit,namestr,ivalue,fmt)
! Writes a string of the form <name> = ivalue to unit
integer(ki8) :: ivalue
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(ivalue,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
end subroutine writeq_di
!**********************************************************************
subroutine writeq_si(unit,namestr,ivalue,fmt)
! Writes a string of the form <name> = ivalue to unit
integer(ki4) :: ivalue
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(ivalue,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
end subroutine writeq_si
!**********************************************************************
function is_letter(ch) result(res)
! Returns .true. if ch is a letter and .false. otherwise
character :: ch
logical :: res
select case(ch)
case('A':'Z','a':'z')
res=.true.
case default
res=.false.
end select
return
end function is_letter
!**********************************************************************
function is_digit(ch) result(res)
! Returns .true. if ch is a digit (0,1,...,9) and .false. otherwise
character :: ch
logical :: res
select case(ch)
case('0':'9')
res=.true.
case default
res=.false.
end select
return
end function is_digit
!**********************************************************************
subroutine split(str,delims,before,sep)
! Routine finds the first instance of a character from 'delims' in the
! the string 'str'. The characters before the found delimiter are
! output in 'before'. The characters after the found delimiter are
! output in 'str'. The optional output character 'sep' contains the
! found delimiter. A delimiter in 'str' is treated like an ordinary
! character if it is preceded by a backslash (\). If the backslash
! character is desired in 'str', then precede it with another backslash.
character(len=*) :: str,delims,before
character,optional :: sep
logical :: pres
character :: ch,cha
pres=present(sep)
str=adjustl(str)
call compact(str)
lenstr=len_trim(str)
if(lenstr == 0) return ! string str is empty
k=0
ibsl=0 ! backslash initially inactive
before=' '
do i=1,lenstr
ch=str(i:i)
if(ibsl == 1) then ! backslash active
k=k+1
before(k:k)=ch
ibsl=0
cycle
end if
if(ch == '\\') then ! backslash with backslash inactive
k=k+1
before(k:k)=ch
ibsl=1
cycle
end if
ipos=index(delims,ch)
if(ipos == 0) then ! character is not a delimiter
k=k+1
before(k:k)=ch
cycle
end if
if(ch /= ' ') then ! character is a delimiter that is not a space
str=str(i+1:)
if(pres) sep=ch
exit
end if
cha=str(i+1:i+1) ! character is a space delimiter
iposa=index(delims,cha)
if(iposa > 0) then ! next character is a delimiter
str=str(i+2:)
if(pres) sep=cha
exit
else
str=str(i+1:)
if(pres) sep=ch
exit
end if
end do
if(i >= lenstr) str=''
str=adjustl(str) ! remove initial spaces
return
end subroutine split
!**********************************************************************
subroutine removebksl(str)
! Removes backslash (\) characters. Double backslashes (\\) are replaced
! by a single backslash.
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str))::outstr
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
k=0
ibsl=0 ! backslash initially inactive
do i=1,lenstr
ch=str(i:i)
if(ibsl == 1) then ! backslash active
k=k+1
outstr(k:k)=ch
ibsl=0
cycle
end if
if(ch == '\\') then ! backslash with backslash inactive
ibsl=1
cycle
end if
k=k+1
outstr(k:k)=ch ! non-backslash with backslash inactive
end do
str=adjustl(outstr)
end subroutine removebksl
!**********************************************************************
end module strings

/tags/1.0/goodies/timeres.f
0,0 → 1,415
PROGRAM timeresolution
c ***********************************************************************
c * Change time resolution of of a trajectory file *
c * Michael Sprenger / Winter 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Parameters
character*80 inpfile
character*80 outfile
integer ntra,otim,ncol
real timeres
character*80 unit
character*80 mode
c Trajectories
character*80 vars(100)
integer refdate(6)
integer ntim
real,allocatable, dimension (:,:,:) :: trainp
real,allocatable, dimension (:,:,:) :: traout
real,allocatable, dimension (:) :: timold,timnew
real,allocatable, dimension (:) :: fldold,fldnew
c Numerical constants
real eps
parameter (eps=0.001)
c Auxiliary variables
integer inpmode
integer outmode
integer stat
integer fid
integer i,j,k
real hhmm,tfrac
real range
c ----------------------------------------------------------------------
c Parameter handling
c ----------------------------------------------------------------------
c Read parameters
open(10,file='timeres.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) ntra,otim,ncol
read(10,*) timeres
read(10,*) unit
read(10,*) mode
close(10)
c Change unit to minutes
if ( unit.eq.'min') then
timeres = 1./60. * timeres
unit = 'h'
endif
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c ----------------------------------------------------------------------
c Read input trajectory and allocate memory
c ----------------------------------------------------------------------
c Allocate memory for input trajectories
allocate(trainp(ntra,otim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp ***'
allocate(timold(otim),stat=stat)
if (stat.ne.0) print*,'*** error allocating array timold ***'
allocate(fldold(otim),stat=stat)
if (stat.ne.0) print*,'*** error allocating array fldold ***'
c Read inpufile
call ropen_tra(fid,inpfile,ntra,otim,ncol,refdate,vars,inpmode)
call read_tra (fid,trainp,ntra,otim,ncol,inpmode)
call close_tra(fid,inpmode)
c Check that first four columns correspond to time,lon,lat,p
if ( (vars(1).ne.'time' ).or.
> (vars(2).ne.'xpos' ).and.(vars(2).ne.'lon' ).or.
> (vars(3).ne.'ypos' ).and.(vars(3).ne.'lat' ).or.
> (vars(4).ne.'ppos' ).and.(vars(4).ne.'p' ) )
>then
print*,' ERROR: problem with input trajectories ...'
stop
endif
c Convert all times from hhmm to fractional time
do i=1,ntra
do j=1,otim
hhmm = trainp(i,j,1)
call hhmm2frac(hhmm,tfrac)
trainp(i,j,1) = tfrac
enddo
enddo
c Get the time range in minutes
range = ( trainp(1,otim,1) - trainp(1,1,1) )
c Determine the new number of times
ntim = nint( abs( range ) / timeres ) + 1
c Check that the time range and new time resolution are consistent
if ( abs( real(ntim-1) * timeres -range ).gt.eps ) then
print*,' ERROR: time range and resolution are not compatible'
print*,' range = ',range
print*,' (ntim-1) * timeres = ',real(ntim-1) * timeres
stop
endif
c Allocate memory for output trajectories
allocate(traout(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp ***'
allocate(timnew(ntim),stat=stat)
if (stat.ne.0) print*,'*** error allocating array timnew ***'
allocate(fldnew(ntim),stat=stat)
if (stat.ne.0) print*,'*** error allocating array fldnew ***'
c Define the old and new times
do i=1,otim
timold(i) = trainp(1,i,1)
enddo
do i=1,ntim
timnew(i) = timold(1) + real(i-1) * timeres
enddo
c ----------------------------------------------------------------------
c Change time resolution
c ----------------------------------------------------------------------
do i=1,ntra
do k=2,ncol
c Copy old field
do j=1,otim
fldold(j) = trainp(i,j,k)
enddo
c Exception: Handle date line problem for longitude
if ( k.eq.2 ) then
do j=2,otim
if ( (fldold(j-1)-fldold(j)).gt.180. ) then
fldold(j) = fldold(j) + 360.
else if ( (fldold(j-1)-fldold(j)).lt.-180. ) then
fldold(j) = fldold(j) - 360.
endif
enddo
endif
c Cubic spline fitting
if ( mode.eq.'cubic' ) then
call cubicfit (timold,fldold,otim,timnew,fldnew,ntim)
else if (mode.eq.'linear' ) then
call linearfit(timold,fldold,otim,timnew,fldnew,ntim)
endif
c Exception: Reverse date line handling for longitude
if ( k.eq.2 ) then
do j=1,ntim
if ( fldnew(j).gt.180. ) then
fldnew(j) = fldnew(j) -360.
else if ( fldnew(j).lt.-180. ) then
fldnew(j) = fldnew(j) +360.
endif
enddo
endif
c Save the new field in the output trajectory
do j=1,ntim
traout(i,j,1) = timnew(j)
traout(i,j,k) = fldnew(j)
enddo
enddo
enddo
c ----------------------------------------------------------------------
c Write output trajectory
c ----------------------------------------------------------------------
c Convert all times from fractional to hhmm time
do i=1,ntra
do j=1,ntim
tfrac = traout(i,j,1)
call frac2hhmm(tfrac,hhmm)
traout(i,j,1) = hhmm
enddo
enddo
c Write output file
call wopen_tra(fid,outfile,ntra,ntim,ncol,refdate,vars,outmode)
call write_tra(fid,traout,ntra,ntim,ncol,outmode)
call close_tra(fid,outmode)
end
c ********************************************************************
c * REPARAMETERIZATION SUBROUTINES *
c ********************************************************************
c -------------------------------------------------------------
c Interpolation of the trajectory with linear interpolation
c -------------------------------------------------------------
SUBROUTINE linearfit (time,lon,n,sptime,splon,spn)
c Given the curve <time,lon> with <n> data points, fit a
c linear fit to this curve. The new curve is returned in
c <sptime,splon,spn> with <spn> data points. The parameter
c <spn> specifies on entry the number of interpolated points
c along the curve.
implicit none
c Declaration of subroutine parameters
integer n
real time(n),lon(n)
integer spn
real sptime(spn),splon(spn)
c Auxiliary variables
real dt
real s
integer i,j,iold
real order
c Determine whether the input array is ascending or descending
if (time(1).gt.time(n)) then
order=-1.
else
order= 1.
endif
c Bring the time array into ascending order
do i=1,n
time(i)=order*time(i)
enddo
c Prepare the linear interpolation: define the new times
dt=(time(n)-time(1))/real(spn-1)
do i=1,spn
sptime(i)=time(1)+real(i-1)*dt
enddo
c Do the interpolation
iold = 1
do i=1,spn
c Decide which interval of the old time series must be taken
do j=iold,n-1
if ( ( sptime(i).ge.time(j ) ).and.
> ( sptime(i).lt.time(j+1) ) )
> then
iold = j
exit
endif
enddo
c Do the linear interpolation
splon(i) = lon(iold) + ( lon(iold+1) - lon(iold) ) *
> ( sptime(i) - time(iold) ) / ( time(iold+1) - time(iold) )
enddo
c Change the time arrays back: original order
do i=1,spn
sptime(i)=order*sptime(i)
enddo
do i=1,n
time(i)=order*time(i)
enddo
return
end
c -------------------------------------------------------------
c Interpolation of the trajectory with a natural cubic spline
c -------------------------------------------------------------
SUBROUTINE cubicfit (time,lon,n,sptime,splon,spn)
c Given the curve <time,lon> with <n> data points, fit a
c cubic spline to this curve. The new curve is returned in
c <sptime,splon,spn> with <spn> data points. The parameter
c <spn> specifies on entry the number of spline interpolated points
c along the curve.
implicit none
c Declaration of subroutine parameters
integer n
real time(n),lon(n)
integer spn
real sptime(spn),splon(spn)
c Auxiliary variables
real y2ax(n)
real dt
real s
integer i
real order
c Determine whether the input array is ascending or descending
if (time(1).gt.time(n)) then
order=-1.
else
order= 1.
endif
c Bring the time array into ascending order
do i=1,n
time(i)=order*time(i)
enddo
c Prepare the (natural) cubic spline interpolation
call spline (time,lon,n,1.e30,1.e30,y2ax)
dt=(time(n)-time(1))/real(spn-1)
do i=1,spn
sptime(i)=time(1)+real(i-1)*dt
enddo
c Do the spline interpolation
do i=1,spn
call splint(time,lon,y2ax,n,sptime(i),s)
splon(i)=s
enddo
c Change the time arrays back
do i=1,spn
sptime(i)=order*sptime(i)
enddo
do i=1,n
time(i)=order*time(i)
enddo
return
end
c -------------------------------------------------------------
c Basic routines for spline interpolation (Numerical Recipes)
c -------------------------------------------------------------
SUBROUTINE spline(x,y,n,yp1,ypn,y2)
INTEGER n,NMAX
REAL yp1,ypn,x(n),y(n),y2(n)
PARAMETER (NMAX=500)
INTEGER i,k
REAL p,qn,sig,un,u(NMAX)
if (yp1.gt..99e30) then
y2(1)=0.
u(1)=0.
else
y2(1)=-0.5
u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
endif
do 11 i=2,n-1
sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
p=sig*y2(i-1)+2.
y2(i)=(sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+
*1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
*u(i-1))/p
11 continue
if (ypn.gt..99e30) then
qn=0.
un=0.
else
qn=0.5
un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
endif
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
do 12 k=n-1,1,-1
y2(k)=y2(k)*y2(k+1)+u(k)
12 continue
return
END
SUBROUTINE splint(xa,ya,y2a,n,x,y)
INTEGER n
REAL x,y,xa(n),y2a(n),ya(n)
INTEGER k,khi,klo
REAL a,b,h
klo=1
khi=n
1 if (khi-klo.gt.1) then
k=(khi+klo)/2
if(xa(k).gt.x)then
khi=k
else
klo=k
endif
goto 1
endif
h=xa(khi)-xa(klo)
if (h.eq.0.) pause 'bad xa input in splint'
a=(xa(khi)-x)/h
b=(x-xa(klo))/h
y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**
*2)/6.
return
END

/tags/1.0/goodies/timeres.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = timeres.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
timeres: $(OBJS)
${F77} -o timeres $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/timeres.sh
0,0 → 1,70
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp timeres short
echo
exit 0
endif
# Get input and output trajectory file
set inpfile = $1
set outfile = $2
# Handle optional arguments
set mode = "cubic"
while ( $#argv > 0 )
switch ( $argv[1] )
case -h
set unit = "h"
set value = $argv[2]
shift;
breaksw
case -min
set unit = "min"
set value = $argv[2]
shift;
breaksw
case -linear
set mode = "linear"
breaksw
case -cubic
set mode = "cubic"
breaksw
endsw
shift;
end
# Get the dimensions of the trajectory file
set dim=`${LAGRANTO}/goodies/trainfo.sh ${inpfile} dim`
# Prepare parameter file and run program
\rm -f timeres.param
echo \"${inpfile}\" >! timeres.param
echo \"${outfile}\" >> timeres.param
echo ${dim} >> timeres.param
echo ${value} >> timeres.param
echo \"${unit}\" >> timeres.param
echo \"${mode}\" >> timeres.param
${LAGRANTO}/goodies/timeres
# Make clean
#\rm -f timeres.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/tracal.f
0,0 → 1,127
PROGRAM tracal
c ***********************************************************************
c * Calculations with trajectories *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
use evaluate
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Input and output format for trajectories (see iotra.f)
character*80 inpfile ! Input filename
character*80 outfile ! Output filename
character*80 expr ! Expression for calculation
c Trajectories
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
real,allocatable, dimension (:,:,:) :: trainp ! Trajectories (ntra,ntim,ncol )
real,allocatable, dimension (:,:,:) :: traout ! Trajectories (ntra,ntim,ncol+1)
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
c Auxiliary variables
integer inpmode
integer outmode
integer stat
integer fid
integer i,j,k
character (len=24) col,new
real value
character ch
integer ileft,iright
c ----------------------------------------------------------------------
c Do the reformating
c ----------------------------------------------------------------------
c Read parameters
open(10,file='tracal.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) expr
read(10,*) ntra,ntim,ncol
close(10)
c Get the name of the output field
ileft = 1
iright = 0
do i=1,80
if ( expr(i:i).eq.'=' ) iright = i
enddo
if ( iright.eq.0 ) then
vars(ncol+1) = 'CALC'
expr = 'CALC='//trim(expr)
else
vars(ncol+1) = trim( expr(1:iright-1) )
endif
new = vars( ncol+1 )
print*,'inp = ',trim(inpfile)
print*,'out = ',trim(outfile)
print*,'expr = ',trim(expr),' ---> ',trim( new )
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
c Allocate memory
allocate(trainp(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array trainp ***'
allocate(traout(ntra,ntim,ncol+1),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traout ***'
c Read inpufile
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,trainp,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Copy to output trajectory
do i=1,ntra
do j=1,ntim
do k=1,ncol
traout(i,j,k) = trainp(i,j,k)
enddo
enddo
enddo
c Loop over all trajectories
do i=1,ntra
do j=1,ntim
do k=1,ncol
c Attribute trajectory values to symbols
col = vars(k)
call defparam( col, traout(i,j,k) )
enddo
c Evaluate expression
call evaleqn(expr)
c Get the result
call getparam(new,value)
traout(i,j,ncol+1) = value
enddo
enddo
c Write output file
call wopen_tra(fid,outfile,ntra,ntim,ncol+1,refdate,vars,outmode)
call write_tra(fid,traout,ntra,ntim,ncol+1,outmode)
call close_tra(fid,outmode)
end

/tags/1.0/goodies/tracal.install
0,0 → 1,49
# ----- Load modules --------------------------
module load netcdf/4.2.1-pgf90
module list
set tool = tracal
# ----- Set libraries and includes ------------
set libs = "${LAGRANTO}/lib/iotra.a"
set libs = "${libs} -L ${LAGRANTO}/lib"
set libs = "${libs} -lcdfio"
set libs = "${libs} -lcdfplus"
set ncdf_incs = `nc-config --fflags`
set ncdf_libs = `nc-config --flibs`
# ---- Modules ---------------------------------
\rm -f precmod.o precision.mod
echo ${FORTRAN} -c precmod.f90
${FORTRAN} -c precmod.f90
\rm -f stringmod.o strings.mod
echo ${FORTRAN} -c stringmod.f90
${FORTRAN} -c stringmod.f90
\rm -f evalmod.o evaluate.mod
echo ${FORTRAN} -c evalmod.f90
${FORTRAN} -c evalmod.f90
set mods = " evalmod.o precmod.o stringmod.o "
# ----- Compile --------------------- ----------
\rm -f ${tool}.o
\rm -f ${tool}
echo "${FORTRAN} -c ${tool}.f ${ncdf_incs}"
${FORTRAN} -c ${tool}.f ${ncdf_incs}
echo "${FORTRAN} -o ${tool} ${tool}.o ${mods} ${libs} ${ncdf_libs}"
${FORTRAN} -o ${tool} ${tool}.o ${mods} ${libs} ${ncdf_libs}
if ( ! -f ${tool} ) then
echo "ERROR: compilation of <tool> failed... exit"
exit 1
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/tracal.sh
0,0 → 1,31
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp tracal short
echo
exit 0
endif
set inpfile = $1
set outfile = $2
set expr = $3
set dim=`${LAGRANTO}/goodies/trainfo.sh ${inpfile} dim`
\rm -f tracal.param
echo \"${inpfile}\" >! tracal.param
echo \"${outfile}\" >> tracal.param
echo \"${expr}\" >> tracal.param
echo ${dim} >> tracal.param
${LAGRANTO}/goodies/tracal
\rm -f tracal.param
exit 0
Property changes:
Added: svn:executable

/tags/1.0/goodies/trainfo.f
0,0 → 1,300
PROGRAM trainfo
c ***********************************************************************
c * Get infos for a trajectory file *
c * Michael Sprenger / Spring, summer 2010 *
c ***********************************************************************
implicit none
c ----------------------------------------------------------------------
c Declaration of variables
c ----------------------------------------------------------------------
c Input file
character*80 inpfile ! Input filename
character*80 mode ! Mode
c Trajectories
integer ntra ! Number of trajectories
integer ntim ! Number of times
integer ncol ! Number of columns
character*80 vars(100) ! Variable names
integer refdate(6) ! Reference date
real,allocatable, dimension (:,:,:) :: tra ! Trajectories (ntra,ntim,ncol)
c Auxiliary variables
integer inpmode
integer stat
integer fid
integer i,j,n
integer old(5)
integer new(5)
integer hour,min
character*20 datestr
character*120 str
character*4 str1
character*2 str2,str3,str4,str5,str6
integer isok
integer nleaving
c ----------------------------------------------------------------------
c Do the reformating
c ----------------------------------------------------------------------
c Read parameters
open(10,file='trainfo.param')
read(10,*) inpfile
read(10,*) mode
close(10)
c Determine the formats
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
c Get the dimension of the trajectory file
call info_tra(inpfile,ntra,ntim,ncol,inpmode)
c Get haeder information
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call close_tra(fid,inpmode)
c Write dimensions
if ( (mode.eq.'dim').or.(mode.eq.'all') ) then
print*,ntra,ntim,ncol
endif
c Write single dimensions
if ( (mode.eq.'ntra').or.(mode.eq.'all') ) then
print*,ntra
endif
if ( (mode.eq.'ntim').or.(mode.eq.'all') ) then
print*,ntim
endif
if ( (mode.eq.'ncol').or.(mode.eq.'all') ) then
print*,ncol
endif
c Write variable names
if ( (mode.eq.'vars').or.(mode.eq.'all') ) then
print*,(trim(vars(i))//' ',i=1,ncol)
endif
c Write reference date
if ( (mode.eq.'refdate').or.(mode.eq.'all') ) then
c Concatenate date string
min = refdate(5)
call datestring(datestr,
> refdate(1),refdate(2),refdate(3),refdate(4) )
if ( min.eq.0 ) then
datestr = trim(datestr)//'00'
elseif (min.lt.10) then
datestr = trim(datestr)//'0'//char(ichar('0')+min)
else
datestr = trim(datestr)//
> char(ichar('0')+int(min/10))//
> char(ichar('0')+mod(min,10))
endif
c Write date string
print*,trim(datestr)
endif
c Load all trajectory times if necessary
if ( (mode.eq.'all' ).or.
> (mode.eq.'times' ).or.
> (mode.eq.'startdate').or.
> (mode.eq.'enddate' ) )
>then
allocate(tra(ntra,ntim,ncol),stat=stat)
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,tra,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
endif
c Write list of all times
if ( (mode.eq.'times').or.(mode.eq.'all') ) then
write(*,'(100f8.2)') (tra(1,i,1),i=1,ntim)
endif
c Write time range
if ( (mode.eq.'timerange').or.(mode.eq.'all') ) then
write(*,'(i6)') refdate(6)
endif
c Write firstdate (reference date + first time)
if ( (mode.eq.'startdate').or.(mode.eq.'all') ) then
c Set the time shift of first time relative to reference date
hour = int(tra(1,1,1))
min = mod(nint(100.*tra(1,1,1)),100) + refdate(5)
if (min.gt.60) then
min = min - 60
hour = hour + 1
endif
if (min.lt.0) then
min = min + 60
hour = hour - 1
endif
if (min.lt.0) then
min = min + 60
hour = hour - 1
endif
c Get new date (hours and minutes)
old(1) = refdate(1)
old(2) = refdate(2)
old(3) = refdate(3)
old(4) = refdate(4)
old(5) = 0
call newdate(old,real(hour),new)
c Concatenate the date string
call datestring(datestr,
> new(1),new(2),new(3),new(4) )
if ( min.eq.0 ) then
datestr = trim(datestr)//'00'
elseif (min.lt.10) then
datestr = trim(datestr)//'0'//char(ichar('0')+min)
else
datestr = trim(datestr)//
> char(ichar('0')+int(min/10))//
> char(ichar('0')+mod(min,10))
endif
c Write date string
print*,trim(datestr)
endif
c Write enddate (reference date + last time)
if ( (mode.eq.'enddate').or.(mode.eq.'all') ) then
c Set the time shift of first time relative to reference date
hour = int(tra(1,ntim,1))
min = mod(nint(100.*tra(1,ntim,1)),100) + refdate(5)
if (min.gt.60) then
min = min - 60
hour = hour + 1
endif
if (min.lt.0) then
min = min + 60
hour = hour - 1
endif
if (min.lt.0) then
min = min + 60
hour = hour - 1
endif
c Get new date (hours and minutes)
old(1) = refdate(1)
old(2) = refdate(2)
old(3) = refdate(3)
old(4) = refdate(4)
old(5) = 0
call newdate(old,real(hour),new)
c Concatenate the date string
call datestring(datestr,
> new(1),new(2),new(3),new(4) )
if ( min.eq.0 ) then
datestr = trim(datestr)//'00'
elseif (min.lt.10) then
datestr = trim(datestr)//'0'//char(ichar('0')+min)
else
datestr = trim(datestr)//
> char(ichar('0')+int(min/10))//
> char(ichar('0')+mod(min,10))
endif
c Write date string
print*,trim(datestr)
endif
c Write trajectories to screen
if ( (mode.eq.'list') ) then
c Read the complete trajectory file
allocate(tra(ntra,ntim,ncol),stat=stat)
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,tra,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Get the strings for output
write(str1,'(i4)') refdate(1)
write(str2,'(i2)') refdate(2)
write(str3,'(i2)') refdate(3)
write(str4,'(i2)') refdate(4)
write(str5,'(i2)') refdate(5)
if (refdate(2).eq. 0) str2(1:1)='0'
if (refdate(3).eq. 0) str3(1:1)='0'
if (refdate(4).eq. 0) str4(1:1)='0'
if (refdate(5).eq. 0) str5(1:1)='0'
if (refdate(2).lt.10) str2(1:1)='0'
if (refdate(3).lt.10) str3(1:1)='0'
if (refdate(4).lt.10) str4(1:1)='0'
if (refdate(5).lt.10) str5(1:1)='0'
c Write the time specification
write(*,'(a15,a4,a2,a2,a1,a2,a2,a13,i8,a4)')
> 'Reference date ',
> str1,str2,str3,'_',str4,str5,
> ' / Time range',refdate(6), ' min'
write(*,*)
c Write variable names
str=''
do i=1,ncol
str=trim(str)//trim(vars(i))
enddo
write(*,'(a6,a9,a8,a6,100a10)') (trim(vars(i)),i=1,ncol)
write(*,'(a6,a9,a8,a6,100a10)')
> '------','---------','--------','------',
> ('----------',i=5,ncol)
do n=1,ntra
write(*,*)
do i=1,ntim
write(*,'(1f7.2,f9.2,f8.2,i6,100f10.3)')
> (tra(n,i,j),j=1,3), ! time, lon, lat
> nint(tra(n,i,4)), ! p
> (tra(n,i,j),j=5,ncol) ! fields
enddo
enddo
endif
c Get number of trajectories leaving domain
if ( (mode.eq.'leaving') ) then
c Read the complete trajectory file
allocate(tra(ntra,ntim,ncol),stat=stat)
call ropen_tra(fid,inpfile,ntra,ntim,ncol,refdate,vars,inpmode)
call read_tra (fid,tra,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Determine the number of trajectories leaving domain
do i=1,ntra
isok = 1
do j=1,ntim
if ( tra(i,j,4).lt.0. ) isok = 0
enddo
if ( isok.eq.0 ) then
nleaving = nleaving + 1
endif
enddo
c Write output
print*,nleaving
endif
end

/tags/1.0/goodies/trainfo.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = trainfo.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
trainfo: $(OBJS)
${F77} -o trainfo $(OBJS) ${INCS} $(LIBS)

/tags/1.0/goodies/trainfo.sh
0,0 → 1,69
#!/bin/csh
# -----------------------------------------------------------------------------
# Set some parameters
# -----------------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Set input file
set inpfile=$1
if ( ${#argv} == 2 ) then
set mode=$2
else
set mode='all'
endif
# Write usage information
if ( ${#argv} == 0) then
echo
${LAGRANTO}/bin/lagrantohelp trainfo short
echo
exit 0
endif
# Set Fortran program
set prog=${LAGRANTO}/goodies/trainfo
# -----------------------------------------------------------------------------
# Run program
# -----------------------------------------------------------------------------
\rm -f trainfo.param
echo \"${inpfile}\" >! trainfo.param
echo \"${mode}\" >> trainfo.param
${prog}
\rm -f trainfo.param
exit 0
# -----------------------------------------------------------------------------
# Old code: shell script extraction of ntra,ntim,ncol
# -----------------------------------------------------------------------------
# Get line numbers of first trajectory block (separated by empty line)
set first=4
loop1:
@ first = ${first} + 1
set line=`sed -ne "${first},${first}p" ${inpfile}`
if ( "${line}" != "" ) goto loop1
@ final = ${first} + 1
loop2:
@ final = ${final} + 1
set line=`sed -ne "${final},${final}p" ${inpfile}`
if ( "${line}" != "" ) goto loop2
@ first = ${first} + 1
@ final = ${final} - 1
# Set the number of fields, of times and of trajectories
set ntime=`echo "1 + ${final} - ${first}" | bc`
set line=`sed -ne "${first},${first}p" ${inpfile}`
set ncol=`echo ${line} | awk '{print NF}'`
set nlines=`wc -l ${inpfile} | awk '{print $1}'`
set ntra=`echo "(${nlines}-4)/(${ntime}+1)" | bc`
# Write info
echo ${ntra} ${ntime} ${ncol}
Property changes:
Added: svn:executable

/tags/1.0/install.csh
0,0 → 1,496
#!/bin/csh
# -----------------------------------------------------------------------------
# Set some general parameters
# -----------------------------------------------------------------------------
# Usage
if ( $#argv == 0 ) then
echo "install.sh [lib|core|goodies|links|all|docu|clean|tag] "
exit 0
endif
# Set the mode
set mode = $1
# Set path to SVN repository
set svnpath=https://svn.iac.ethz.ch/pub/lagranto.20cr/
# Set paths for development and for synchronisation (operational)
set path_devel = "${DYN_TOOLS}/lagranto.20cr/"
set path_sync = "${DYN_TOOLS}/lagranto/"
# Init Fortran compiler and set netCDF acccordingly
setenv FORTRAN pgf90
# Init netCDF library depending on the Fortran compiler
if ( "${FORTRAN}" == "pgf90" ) then
module load netcdf/4.2.1-pgf90
module list
else if ( "${FORTRAN}" == "gfortran" ) then
module load gfortran
module load netcdf/4.1.1
else if ( "${FORTRAN}" == "ifort" ) then
module load ifort/10.1.017
module load netcdf/4.1.1-ifort
else
echo "Fortran Compiler ${FORTRAN} not supported... Exit"
exit 1
endif
# -----------------------------------------------------------------------------
# Set internal parameters and detailed installation mode
# -----------------------------------------------------------------------------
# Set LAGRANTO environment variable
setenv LAGRANTO ${path_devel}
# Set netCDF paths
setenv NETCDF_LIB `nc-config --flibs`
setenv NETCDF_INC `nc-config --fflags`
# Set list of core programs
set core = "create_startf caltra trace select density lidar"
# Set list of goodies
set tools = "changet extract gettidiff getvars list2lsl lsl2list mergetra newtime reformat timeres trainfo difference datelist tracal"
# Set list of libraries
set libs = "iotra ioinp inter times libcdfio libcdfplus"
# Core programs
foreach prog ( $core )
if ( "${prog}" == "${mode}" ) then
set core = ${prog}
set mode = "core"
endif
end
# Goodies
foreach tool ( $tools )
if ( "${tool}" == "${mode}" ) then
set tools = ${tool}
set mode = "goodies"
endif
end
# Libraries
foreach lib ( $libs )
if ( "${lib}" == "${mode}" ) then
set libs = ${lib}
set mode = "lib"
endif
end
# Check that the mode is ok
if ( "${mode}" == "all" ) goto modeok
if ( "${mode}" == "lib" ) goto modeok
if ( "${mode}" == "core" ) goto modeok
if ( "${mode}" == "goodies" ) goto modeok
if ( "${mode}" == "links" ) goto modeok
if ( "${mode}" == "clean" ) goto modeok
if ( "${mode}" == "docu" ) goto modeok
if ( "${mode}" == "sync" ) goto modeok
echo "Unsupported mode ${mode} ... Stop"
exit 1
modeok:
# -----------------------------------------------------------------------------
# Create a new tag in SVN repository
# -----------------------------------------------------------------------------
if ( "${mode}" == "tag" ) then
svn info
if ( "${#argv}" != 2 ) then
echo "Usage: install.csh tag id <id=tag number>"
else
set tagnr = $2
endif
svn copy ${svnpath}/trunk ${svnpath}/tags/${tagnr} -m "Release ${tagnr}"
exit 0
endif
# -----------------------------------------------------------------------------
# Make clean
# -----------------------------------------------------------------------------
if ( "${mode}" == "clean" ) then
cd ${LAGRANTO}/
foreach prog ( $core )
\rm -f ${prog}/${prog} ${prog}/${prog}.o
end
\rm -f trace/calvar.o select/special.o
foreach tool ( $tools )
\rm -f goodies/${tool} goodies/${tool}.o
end
\rm -f goodies/*.mod goodies/*.o
\rm lib/*.a lib/*.o
foreach prog ( $core )
\rm -f bin/${prog} bin/${prog}.sh bin/${prog}.20cr
end
\rm -f bin/seltra bin/seltra.sh bin/seltra.20cr
foreach tool ( $tools )
\rm -f bin/${tool} bin/${tool}.sh bin/${tool}.20cr
end
\rm -f bin/lagrantohelp.sh bin/lagrantohelp.20cr
\rm -f bin/startf bin/startf.sh bin/startf.20cr
\rm -f bin/lagranto.sh bin/lagranto.20cr
\rm ${LAGRANTO}/startf
exit 0
endif
# -----------------------------------------------------------------------------
# Install reference
# -----------------------------------------------------------------------------
if ( ("${mode}" == "docu") | ("${mode}" == "all" ) ) then
echo "-----------------------------------------------------------------"
echo "Installing documentation"
echo "-----------------------------------------------------------------"
echo
cd ${LAGRANTO}/docu/reference/
\rm -f reference.ps
\rm -f reference2.ps
groff -man ../man/*.0 > reference2.ps
ps2pdf reference2.ps
latex title
dvips title
ps2pdf title.ps
gs -dBATCH -dNOPAUSE -q -sDEVICE=pdfwrite -sOutputFile=reference.pdf title.pdf reference2.pdf
\rm -f *.aux *.log *.dvi
\rm -f title.ps reference2.ps
\rm -f title.pdf reference2.pdf
endif
if ( "${mode}" == "docu" ) exit 0
# -----------------------------------------------------------------------------
# Install libraries
# -----------------------------------------------------------------------------
if ( ("${mode}" == "lib") | ("${mode}" == "all" ) ) then
echo "-----------------------------------------------------------------"
echo "Installing libraries"
echo "-----------------------------------------------------------------"
echo
# Change to library directory
cd ${LAGRANTO}/lib
# Loop over all libraries - compile and make library
foreach lib ( $libs )
\rm -f ${lib}.a
\rm -f ${lib}.o
echo ${FORTRAN} -c -O ${lib}.f
${FORTRAN} -c -O ${NETCDF_INC} ${lib}.f
ar r ${lib}.a ${lib}.o
\rm -f ${lib}.l ${lib}.o
ranlib ${lib}.a
if ( ! -f ${lib}.a ) then
echo "Problem in compiling ${lib} ... Stop"
exit 1
endif
end
endif
if ( "${mode}" == "lib" ) exit 0
# -----------------------------------------------------------------------------
# Check that libraries are ok
# -----------------------------------------------------------------------------
echo
echo "-----------------------------------------------------------------"
echo "Check that all libraries are available"
echo "-----------------------------------------------------------------"
echo
# Change to library directory
cd ${LAGRANTO}/lib
# Check whether all libraries are available
foreach lib ( $libs )
if ( ! -f ${lib}.a ) then
echo "Library ${lib} missing... Stop"
exit 1
else
ls -l ${lib}.a
endif
end
# Exit if only libraries shoudl be installed
if ( "${mode}" == "lib" ) exit 0
# -----------------------------------------------------------------------------
# Compile Lagrango core programs
# -----------------------------------------------------------------------------
if ( ("${mode}" == "all" ) | ("${mode}" == "core" ) ) then
echo
echo "-----------------------------------------------------------------"
echo "Installing Lagranto core programs"
echo "-----------------------------------------------------------------"
foreach prog ( $core )
echo
echo "----- $prog"
echo
cd ${LAGRANTO}/${prog}
\rm -f ${prog}.o
\rm -f ${prog}
if ( "${prog}" == "trace" ) \rm calvar.o
if ( "${prog}" == "select" ) \rm special.o
\rm -f ${prog}
make -f ${prog}.make
if ( ! -f ${prog} ) then
echo "Problem in compiling ${prog} ... Stop"
exit 1
endif
end
endif
if ( "${mode}" == "core" ) exit 0
# -----------------------------------------------------------------------------
# Check that all Lagranto core programs are available
# -----------------------------------------------------------------------------
echo
echo "-----------------------------------------------------------------"
echo "Check that all Lagranto core programs are available"
echo "-----------------------------------------------------------------"
echo
foreach prog ( $core )
cd ${LAGRANTO}/${prog}
if ( ! -f ${prog} ) then
echo "${prog} is missing... Stop"
exit 1
else
ls -l ${prog}
endif
end
# Exit if only core programs shoudl be installed
if ( "${mode}" == "core" ) exit 0
# -----------------------------------------------------------------------------
# Compile Lagrango goodies
# -----------------------------------------------------------------------------
if ( ("${mode}" == "all" ) | ("${mode}" == "goodies" ) ) then
echo
echo "-----------------------------------------------------------------"
echo "Installing Lagranto goodies"
echo "-----------------------------------------------------------------"
cd ${LAGRANTO}/goodies
foreach tool ( $tools )
echo
echo "----- ${tool}"
echo
\rm -f ${tool}.o
\rm -f ${tool}
if ( -f ${tool}.make ) then
make -f ${tool}.make
else if ( -f ${tool}.install ) then
./${tool}.install
endif
if ( ! -f ${tool} ) then
echo "Problem in compiling ${tool} ... Stop"
exit 1
endif
end
endif
if ( "${mode}" == "goodies" ) exit 0
# -----------------------------------------------------------------------------
# Check that all Lagranto goodies are available
# -----------------------------------------------------------------------------
echo
echo "-----------------------------------------------------------------"
echo "Check that all Lagranto goodies are available"
echo "-----------------------------------------------------------------"
echo
cd ${LAGRANTO}/goodies
foreach tool ( $tools )
if ( ! -f ${tool} ) then
echo "${tool} is missing... Stop"
exit 1
else
ls -l ${tool}
endif
end
endif
# Exit if only goodies should be installed
if ( "${mode}" == "goodies" ) exit 0
# -----------------------------------------------------------------------------
# Create links to programs
# -----------------------------------------------------------------------------
if ( ("${mode}" == "all" ) | ("${mode}" == "links" ) ) then
echo
echo "-----------------------------------------------------------------"
echo "Create links in ${LAGRANTO}/bin/"
echo "-----------------------------------------------------------------"
echo
if ( ! -d ${LAGRANTO}/bin ) mkdir ${LAGRANTO}/bin
cd ${LAGRANTO}/bin
ln -svf ${LAGRANTO}/bin/lagranto lagranto.20cr
ln -svf ${LAGRANTO}/bin/lagrantohelp lagrantohelp.20cr
ln -svf ${LAGRANTO}/caltra/caltra.sh caltra.20cr
ln -svf ${LAGRANTO}/startf/create_startf.sh create_startf.20cr
ln -svf ${LAGRANTO}/select/select.sh select.20cr
ln -svf ${LAGRANTO}/select/select.sh seltra.20cr
ln -svf ${LAGRANTO}/trace/trace.sh trace.20cr
ln -svf ${LAGRANTO}/density/density.sh density.20cr
ln -svf ${LAGRANTO}/startf/create_startf.sh startf.20cr
ln -svf ${LAGRANTO}/lidar/lidar.sh lidar.20cr
#ln -svf ${LAGRANTO}/bin/lagranto lagranto
#ln -svf ${LAGRANTO}/bin/lagrantohelp lagrantohelp
ln -svf ${LAGRANTO}/caltra/caltra.sh caltra
ln -svf ${LAGRANTO}/startf/create_startf.sh create_startf
ln -svf ${LAGRANTO}/select/select.sh select
ln -svf ${LAGRANTO}/select/select.sh seltra
ln -svf ${LAGRANTO}/trace/trace.sh trace
ln -svf ${LAGRANTO}/density/density.sh density
ln -svf ${LAGRANTO}/startf/create_startf.sh startf
ln -svf ${LAGRANTO}/lidar/lidar.sh lidar
ln -svf ${LAGRANTO}/bin/lagranto lagranto.sh
ln -svf ${LAGRANTO}/bin/lagrantohelp lagrantohelp.sh
ln -svf ${LAGRANTO}/caltra/caltra.sh caltra.sh
ln -svf ${LAGRANTO}/startf/create_startf.sh create_startf.sh
ln -svf ${LAGRANTO}/select/select.sh select.sh
ln -svf ${LAGRANTO}/select/select.sh seltra.sh
ln -svf ${LAGRANTO}/trace/trace.sh trace.sh
ln -svf ${LAGRANTO}/density/density.sh density.sh
ln -svf ${LAGRANTO}/startf/create_startf.sh startf.sh
ln -svf ${LAGRANTO}/lidar/lidar.sh lidar.sh
foreach tool ( $tools )
ln -svf ${LAGRANTO}/goodies/${tool}.sh ${tool}.20cr
ln -svf ${LAGRANTO}/goodies/${tool}.sh ${tool}
ln -svf ${LAGRANTO}/goodies/${tool}.sh ${tool}.sh
end
# Set link for create_startf / startf
\rm -f ${LAGRANTO}/startf
ln -svf ${LAGRANTO}/create_startf ${LAGRANTO}/startf
# Set extra name for <select> to avoid conflict in BASH
ln -svf ${LAGRANTO}/select/select.sh seltra.20cr
ln -svf ${LAGRANTO}/select/select.sh seltra.sh
ln -svf ${LAGRANTO}/select/select.sh seltra
endif
# -----------------------------------------------------------------------------
# Synchronise ( development -> operational )
# -----------------------------------------------------------------------------
if ( ("${mode}" == "all" ) | ("${mode}" == "sync" ) ) then
echo
echo "-----------------------------------------------------------------"
echo "Sync ( lagranto.20cr -> lagranto )"
echo "-----------------------------------------------------------------"
echo
cd ${path_sync}/bin/
ln -svf ${path_devel}/bin/lagranto.sh lagranto.20cr
ln -svf ${path_devel}/bin/lagrantohelp.sh lagrantohelp.20cr
ln -svf ${path_devel}/caltra/caltra.sh caltra.20cr
ln -svf ${path_devel}/startf/create_startf.sh create_startf.20cr
ln -svf ${path_devel}/select/select.sh select.20cr
ln -svf ${path_devel}/trace/trace.sh trace.20cr
ln -svf ${path_devel}/density/density.sh density.20cr
ln -svf ${path_devel}/startf/create_startf.sh startf.20cr
ln -svf ${path_devel}/lidar/lidar.sh lidar.20cr
ln -svf ${path_devel}/lidar/seltra.sh seltra.20cr
foreach tool ( $tools )
ln -svf ${path_devel}/goodies/${tool}.sh ${tool}.20cr
end
# Set all permissions
chmod -R og+rx ${path_sync}/bin/
endif
# -----------------------------------------------------------------------------
# Final tasks
# -----------------------------------------------------------------------------
echo
echo "-----------------------------------------------------------------"
echo "Installation complete"
echo "-----------------------------------------------------------------"
echo
echo "Please set the environmental variable LAGRANTO"
echo
echo " setenv LAGRANTO ${LAGRANTO}"
echo
Property changes:
Added: svn:executable

/tags/1.0/lagranto.20cr.docu
0,0 → 1,0
${DYN_TOOLS}/lagranto.20cr/bin/lagrantohelp
Property changes:
Added: svn:executable

/tags/1.0/lagranto.20cr.install
0,0 → 1,7
#!/bin/csh
# ----- Run Lagrantoninstaller -------------------
./install.csh all
exit 0
Property changes:
Added: svn:executable

/tags/1.0/lib/inter.f
0,0 → 1,485
c *************************************************************
c * This package provides a general interpolaton routine *
c *************************************************************
c The main interface routines are:
c get_index3,4 : get the grid indices for interpolation
c int_index3,4 : interpolate to the grid position
c -------------------------------------------------------------
c Get index in grid space for interpolation
c -------------------------------------------------------------
subroutine get_index4 (rid,rjd,rkd,xpo,ypo,ppo,rtp,
> vert0,vert1,surf0,surf1,mode,
> nx,ny,nz,lonw,lats,dlon,dlat,misdat)
c Purpose:
c This subroutine determines the indices (rid,rjd,rkd) in grid
c space for a point in physical space (xpo,ypo,ppo). The
c horizontal grid is specified by the south-west point (lats,lonw)
c and the grid spacing (dlat,dlon). The vertical grid is given
c by <vert(n1,n2,n3)>. The lower boundary (typicall surface
c pressure) is given by <surf(n1,n2)>.
c Arguments:
c rid,rjd,rkd real output grid location to be interpolated to
c xpo,ypo,ppo real input physical coordinates
c rtp real input relative time position (0=beginning, 1=end)
c n1,n2,n3 int input grid dimensions in x-, y- and p-direction
c lats,lonw real input south and west boundary of grid space
c vert real input vertical coordinate grid
c surf real input lower boundary (surface pressure)
c mode int input direction of vertical axis (p=1,th=-1)
c 1: linear, 1 -> nz (th)
c 2: linear, nz -> 1 (pv)
c 3: binary (p)
implicit none
c Declartion of function parameters
integer nx,ny,nz
real xpo,ypo,ppo,rtp
real vert0(nx*ny*nz),vert1(nx*ny*nz)
real surf0(nx*ny) ,surf1(nx*ny*nz)
real rid,rjd,rkd
real dlat,dlon,lats,lonw
real misdat
integer mode
c Set numerical parameters
real eps
parameter (eps=1.e-8)
c Auxiliary variables
real rid0,rjd0,rkd0,rid1,rjd1,rkd1
c Externals
real int_time
external int_time
c Get the inidices
if (abs(rtp).lt.eps) then
call get_index3 (rid,rjd,rkd,xpo,ypo,ppo,mode,
> vert0,surf0,nx,ny,nz,lonw,lats,dlon,dlat)
elseif (abs(rtp-1.).lt.eps) then
call get_index3 (rid,rjd,rkd,xpo,ypo,ppo,mode,
> vert1,surf1,nx,ny,nz,lonw,lats,dlon,dlat)
else
call get_index3 (rid0,rjd0,rkd0,xpo,ypo,ppo,mode,
> vert0,surf0,nx,ny,nz,lonw,lats,dlon,dlat)
call get_index3 (rid1,rjd1,rkd1,xpo,ypo,ppo,mode,
> vert1,surf1,nx,ny,nz,lonw,lats,dlon,dlat)
rid = int_time (rid0,rid1,rtp,misdat)
rjd = int_time (rjd0,rjd1,rtp,misdat)
rkd = int_time (rkd0,rkd1,rtp,misdat)
endif
end
c -------------------------------------------------------------
c Interpolate to an arbitrary position in grid space and time
c -------------------------------------------------------------
real function int_index4 (ar0,ar1,n1,n2,n3,rid,rjd,rkd,rtp,misdat)
c Purpose:
c This subroutine interpolates a 3d-array to an arbitrary
c location within the grid including a linear time-interpolation.
c Arguments:
c rid,rjd,rkd real output grid location to be interpolated to
c xpo,ypo,ppo real input physical coordinates
c n1,n2,n3 int input grid dimensions in x-, y- and p-direction
c lats,lonw real input south and west boundary of grid space
c vert real input vertical coordinate grid
c surf real input lower boundary (surface pressure)
implicit none
c Declartion of function parameters
integer n1,n2,n3
real ar0(n1*n2*n3),ar1(n1*n2*n3)
real rid,rjd,rkd
real rtp
real misdat
c Set numerical parameters
real eps
parameter (eps=1.e-8)
c Externals
real int_index3,int_time
external int_index3,int_time
c Auxiliary variables
real val0,val1,val
c Do the 3d-interpolation
if (abs(rtp).lt.eps) then
val = int_index3 (ar0,n1,n2,n3,rid,rjd,rkd,misdat)
elseif (abs(rtp-1.).lt.eps) then
val = int_index3 (ar1,n1,n2,n3,rid,rjd,rkd,misdat)
else
val0 = int_index3 (ar0,n1,n2,n3,rid,rjd,rkd,misdat)
val1 = int_index3 (ar1,n1,n2,n3,rid,rjd,rkd,misdat)
val = int_time (val0,val1,rtp,misdat)
endif
c Return value
int_index4 = val
return
end
c -------------------------------------------------------------
c Interpolate to an arbitrary position in grid space
c -------------------------------------------------------------
real function int_index3 (ar,n1,n2,n3,rid,rjd,rkd,misdat)
c Purpose:
c This subroutine interpolates a 3d-array to an arbitrary
c location within the grid. The interpolation includes the
c testing of the missing data flag 'misdat'. If one dimension
c is 1, a 2d-interpolation is performed; if two dimensions
c are 1, it is a 1d-interpolation; if all three dimensions are
c 1, no interpolation is performed and the input value is
c returned.
c Arguments:
c ar real input input data array
c n1,n2,n3 int input dimensions of ar
c ri,rj,rk real input grid location to be interpolated to
c misdat real input missing data flag (on if misdat<>0)
implicit none
c Declartion of function parameters
integer n1,n2,n3
real ar(n1*n2*n3)
real rid,rjd,rkd
real misdat
c Set numerical parameters
real eps
parameter (eps=1.e-8)
c Local variables
integer i,j,k,ip1,jp1,kp1
real frac0i,frac0j,frac0k,frac1i,frac1j,frac1k
real ri,rj,rk
real val000,val001,val010,val011,val100,val101,val110,val111
real frc000,frc001,frc010,frc011,frc100,frc101,frc110,frc111
real frc
real mdv
real val
c Elementary test for dimensions
if ( (n1.lt.1).or.(n2.lt.1).or.(n3.lt.1) ) then
print*,'Invalid grid dimensions ',n1,n2,n3
stop
endif
c Activate or inactive the missing data check (quick and dirty)
if (misdat.ne.0.) then
mdv = misdat
else
mdv = 257.22725394015
endif
c Bring the indices into the grid space
ri = amax1(1.,amin1(float(n1),rid))
rj = amax1(1.,amin1(float(n2),rjd))
rk = amax1(1.,amin1(float(n3),rkd))
c Get the index of the west-south-bottom corner of the box
i = min0(int(ri),n1-1)
ip1 = i+1
j = min0(int(rj),n2-1)
jp1 = j+1
k = min0(int(rk),n3-1)
kp1 = k+1
c Special handling for 2d arrays
if (n3.eq.1) then
k=1
kp1=1
endif
c Get location relative to grid box
if ( i.ne.ip1 ) then
frac0i = ri-float(i)
frac1i = 1.-frac0i
else
frac0i = 0.
frac1i = 1.
endif
if ( j.ne.jp1 ) then
frac0j = rj-float(j)
frac1j = 1.-frac0j
else
frac0j = 0.
frac1j = 1.
endif
if ( k.ne.kp1 ) then
frac0k = rk-float(k)
frac1k = 1.-frac0k
else
frac0k = 0.
frac1k = 1.
endif
c On a grid point - take the grid point value
if ( ( abs(frac0i).lt.eps ).and.
> ( abs(frac0j).lt.eps ).and.
> ( abs(frac0k).lt.eps ) ) then
val = ar( i + n1*(j -1) + n1*n2*(k -1) )
goto 100
endif
c Init the fractions
frc000 = frac1i * frac1j * frac1k
frc001 = frac0i * frac1j * frac1k
frc010 = frac1i * frac0j * frac1k
frc011 = frac0i * frac0j * frac1k
frc100 = frac1i * frac1j * frac0k
frc101 = frac0i * frac1j * frac0k
frc110 = frac1i * frac0j * frac0k
frc111 = frac0i * frac0j * frac0k
c Init the values
val000 = ar( i + n1*(j -1) + n1*n2*(k -1) )
val001 = ar( ip1 + n1*(j -1) + n1*n2*(k -1) )
val010 = ar( i + n1*(jp1-1) + n1*n2*(k -1) )
val011 = ar( ip1 + n1*(jp1-1) + n1*n2*(k -1) )
val100 = ar( i + n1*(j -1) + n1*n2*(kp1-1) )
val101 = ar( ip1 + n1*(j -1) + n1*n2*(kp1-1) )
val110 = ar( i + n1*(jp1-1) + n1*n2*(kp1-1) )
val111 = ar( ip1 + n1*(jp1-1) + n1*n2*(kp1-1) )
c Handle missing data
if ( abs(val000-mdv).lt.eps ) frc000 = 0.
if ( abs(val001-mdv).lt.eps ) frc001 = 0.
if ( abs(val010-mdv).lt.eps ) frc010 = 0.
if ( abs(val011-mdv).lt.eps ) frc011 = 0.
if ( abs(val100-mdv).lt.eps ) frc100 = 0.
if ( abs(val101-mdv).lt.eps ) frc101 = 0.
if ( abs(val110-mdv).lt.eps ) frc110 = 0.
if ( abs(val111-mdv).lt.eps ) frc111 = 0.
c Build the final value
frc = frc000 + frc001 + frc010 + frc011 +
> frc100 + frc101 + frc110 + frc111
if ( frc.gt.0. ) then
val = 1./frc * ( frc000 * val000 + frc001 * val001 +
> frc010 * val010 + frc011 * val011 +
> frc100 * val100 + frc101 * val101 +
> frc110 * val110 + frc111 * val111 )
else
val = misdat
endif
c Return the value
100 continue
int_index3 = val
end
c -------------------------------------------------------------
c Time interpolation
c -------------------------------------------------------------
real function int_time (val0,val1,reltpos,misdat)
c Purpose:
c This subroutine interpolates linearly in time between two
c values.
c Arguments:
c val0 real input value at time 0
c val1 real input value at time 1
c reltpos real input relative time (between 0 and 1)
c misdat real input missing data flag (on if misdat<>0)
implicit none
c Declaration of parameters
real val0
real val1
real reltpos
real misdat
c Numerical epsilon
real eps
parameter (eps=1.e-8)
c Local variables
real val
real mdv
c Activate or inactive the missing data check (quick and dirty)
if (misdat.ne.0.) then
mdv = misdat
else
mdv = 257.22725394015
endif
c Do the linear interpolation
if ( abs(reltpos).lt.eps ) then
val = val0
elseif ( abs(reltpos-1.).lt.eps ) then
val = val1
elseif ( (abs(val0-mdv).gt.eps).and.
> (abs(val1-mdv).gt.eps) ) then
val = (1.-reltpos)*val0+reltpos*val1
else
val = mdv
endif
c Return value
int_time = val
end
c -------------------------------------------------------------
c Get the position of a physical point in grid space
c -------------------------------------------------------------
subroutine get_index3 (rid,rjd,rkd,xpo,ypo,ppo,mode,
> vert,surf,nx,ny,nz,lonw,lats,dlon,dlat)
c Purpose:
c This subroutine determines the indices (rid,rjd,rkd) in grid
c space for a point in physical space (xpo,ypo,ppo). The
c horizontal grid is specified by the south-west point (lats,lonw)
c and the grid spacing (dlat,dlon). The vertical grid is given
c by <vert(n1,n2,n3)>. The lower boundary (typicall surface
c pressure) is given by <surf(n1,n2)>.
c Arguments:
c rid,rjd,rkd real output grid location to be interpolated to
c xpo,ypo,ppo real input physical coordinates
c n1,n2,n3 int input grid dimensions in x-, y- and p-direction
c lats,lonw real input south and west boundary of grid space
c vert real input vertical coordinate grid
c surf real input lower boundary (surface pressure)
c mode int input direction of vertical axis
c 1: linear, 1 -> nz (th)
c 2: linear, nz -> 1 (pv)
c 3: binary (p)
implicit none
c Declartion of function parameters
integer nx,ny,nz
real vert(nx*ny*nz)
real surf(nx*ny)
real rid,rjd,rkd
real xpo,ypo,ppo
real dlat,dlon,lats,lonw
integer mode
c Numerical epsilon
real eps
parameter (eps=1.e-8)
c Local variables
integer i,j,k
real ppo0,ppo1,ppom,psur
integer i0,im,i1
c Externals
real int_index3
external int_index3
c Get the horizontal grid indices
rid=(xpo-lonw)/dlon+1.
rjd=(ypo-lats)/dlat+1.
c Two-dimensional interpolation on horizontal plane: return
if ( nz.eq.1 ) then
rkd = 1.
goto 100
endif
c Lowest-level interpolation: return
if ( abs(ppo-1050.).lt.eps ) then
rkd = 1.
goto 100
endif
c Get the pressure at the lowest level and at the surface
ppo0 = int_index3(vert,nx,ny,nz,rid,rjd,real(1),0.)
psur = int_index3(surf,nx,ny, 1,rid,rjd,real(1),0.)
c The point is between the surface and the lowest level: return
if ( (ppo.ge.ppo0).and.(ppo.le.psur).or.
> (ppo.le.ppo0).and.(ppo.ge.psur) )
>then
psur = int_index3(surf,nx,ny, 1,rid,rjd,real(1),0.)
rkd = (psur-ppo)/(psur-ppo0)
goto 100
endif
c Full-level search (TH): linear ascending scanning through all levels
if ( mode.eq.1 ) then
ppo0 = int_index3(vert,nx,ny,nz,rid,rjd,real(1),0.)
rkd=0
do i=1,nz-1
ppo1 = int_index3(vert,nx,ny,nz,rid,rjd,real(i+1),0.)
if ( (ppo0.lt.ppo).and.(ppo1.ge.ppo) ) then
rkd=real(i)+(ppo0-ppo)/(ppo0-ppo1)
goto 100
endif
ppo0 = ppo1
enddo
c Full-level search (PV): linear descending scanning through all levels
elseif ( mode.eq.2 ) then
ppo1 = int_index3(vert,nx,ny,nz,rid,rjd,real(nz),0.)
rkd=0
do i=nz-1,1,-1
ppo0 = int_index3(vert,nx,ny,nz,rid,rjd,real(i),0.)
if ( (ppo1.gt.ppo).and.(ppo0.le.ppo) ) then
rkd=real(i)+(ppo0-ppo)/(ppo0-ppo1)
goto 100
endif
ppo1 = ppo0
enddo
c Full-level search (P): binary search
elseif ( mode.eq.3 ) then
rkd = 0
i0 = 1
i1 = nz
ppo0 = int_index3(vert,nx,ny,nz,rid,rjd,real( 1),0.)
ppo1 = int_index3(vert,nx,ny,nz,rid,rjd,real(nz),0.)
do while ( i1.gt.(i0+1) )
im = (i0+i1)/2
ppom = int_index3(vert,nx,ny,nz,rid,rjd,real(im),0.)
if (ppom.lt.ppo) then
i1 = im
ppo1 = ppom
else
i0 = im
ppo0 = ppom
endif
enddo
rkd=real(i0)+(ppo0-ppo)/(ppo0-ppo1)
endif
c Exit point for subroutine
100 continue
end

/tags/1.0/lib/ioinp.f
0,0 → 1,411
c ************************************************************
c * This package provides input routines to read the wind *
c * and other fields from IVE necdf files. The routines are *
c * *
c * 1) input_open : to open a data file *
c * 2) input_grid : to read the grid information, including *
c * the vertical levels *
c * 3) input_wind : to read the wind components *
c * 4) input_close : to close an input file *
c * *
c * The file is characterised by an filename <filename> and *
c * a file identifier <fid>. The horizontal grid is given by *
c * <xmin,xmax,ymin,ymax,dx,dy,nx,ny> where the pole of the *
c * rotated grid is given by <pollon,pollat>. The vertical *
c * grid is characterised by the surface pressure <ps> and *
c * the pressure at staggered <slev> and unstaggered <ulev> *
c * levels. The number of levels is given by <nz>. Finally, *
c * the retrieval of the wind <field> with name <fieldname> *
c * is characterised by a <time> and a missing data value *
c * <mdv>. *
c * *
c * Author: Michael Sprenger, Autumn 2008 *
c ************************************************************
c ------------------------------------------------------------
c Open input file
c ------------------------------------------------------------
subroutine input_open (fid,filename)
c Open the input file with filename <filename> and return the
c file identifier <fid> for further reference.
use netcdf
implicit none
c Declaration of subroutine parameters
integer fid ! File identifier
character*80 filename ! Filename
c Declaration of auxiliary variables
integer ierr
ierr = NF90_OPEN(TRIM(filename),nf90_nowrite, fid)
IF ( ierr /= nf90_NoErr ) PRINT *,NF90_STRERROR(ierr)
end
c ------------------------------------------------------------
c Read information about the grid
c ------------------------------------------------------------
subroutine input_grid
> (fid,fieldname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> time,pollon,pollat,p3,ps,nz,ak,bk,stagz,
> timecheck)
use netcdf
c Read grid information at <time> from file with identifier <fid>.
c The horizontal grid is characterized by <xmin,xmax,ymin,ymax,dx,dy>
c with pole position at <pollon,pollat> and grid dimension <nx,ny>.
c The 3d arrays <p3(nx,ny,nz)> gives the vertical coordinates, either
c on the staggered or unstaggered grid (with <stagz> as the flag).
c The surface pressure is given in <ps(nx,ny)>. If <fid> is negative,
c only the grid dimensions and grid parameters (xmin...pollat,nz) are
c determined and returned (this is needed for dynamical allocation of
c memory).
implicit none
c Declaration of subroutine parameters
integer fid ! File identifier
real xmin,xmax,ymin,ymax ! Domain size
real dx,dy ! Horizontal resolution
integer nx,ny,nz ! Grid dimensions
real pollon,pollat ! Longitude and latitude of pole
real p3(nx,ny,nz) ! Staggered levels
real ps(nx,ny) ! Surface pressure
real time ! Time of the grid information
real ak(nz),bk(nz) ! Ak and Bk for layers or levels
real stagz ! Vertical staggering (0 or -0.5)
character*80 fieldname ! Variable from which to take grid info
character*80 timecheck ! Either 'yes' or 'no'
c Numerical epsilon
real eps
parameter (eps=0.0001)
c Auxiliary varaibles
integer ierr
integer i,j,k
character*80 varname
character*80 newname
real lon(1000),lat(1000),lev(1000),lev2(1000)
integer varid,lonid,latid,levid
integer nz2
real tmp(nx-1,ny)
integer indx
real lon1
integer itmp
c Inquire dimensions and grid constants if <fid> is negative
if (fid.lt.0) then
c Longitude
ierr = nf90_inq_dimid(-fid,'lon', lonid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_inquire_dimension(-fid, lonid, len = nx)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_INQ_VARID(-fid,'lon',varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(-fid,varid,lon(1:nx))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
c Latitude
ierr = nf90_inq_dimid(-fid,'lat', latid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_inquire_dimension(-fid, latid, len = ny)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_INQ_VARID(-fid,'lat',varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(-fid,varid,lat(1:ny))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
c Set grid parameters and compare to expected setting
xmin = lon(1)
xmax = lon(nx)
ymin = lat(ny)
ymax = lat(1)
dx = (xmax-xmin)/real(nx-1)
dy = (ymax-ymin)/real(ny-1)
if (
> ( nx .ne.180 ).or.
> ( ny .ne.91 ).or.
> ( abs(xmin - 0.).gt.eps ).or.
> ( abs(xmax - 358.).gt.eps ).or.
> ( abs(ymin + 90.).gt.eps ).or.
> ( abs(ymax - 90.).gt.eps ).or.
> ( abs(dx - 2.).gt.eps ).or.
> ( abs(dy - 2.).gt.eps ) )
> then
print*,' ERROR: grid does not agree with expectation.. Stop'
stop
endif
c Vertical levels
ierr = nf90_inq_dimid(-fid,'level', levid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_inquire_dimension(-fid, levid, len = nz)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_INQ_VARID(-fid,'level',varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(-fid,varid,lev(1:nz))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
c Get vertical levels for omega and check consistence
ierr = nf90_inq_dimid(-fid,'level_2', levid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_inquire_dimension(-fid, levid, len = nz2)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_INQ_VARID(-fid,'level_2',varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(-fid,varid,lev2(1:nz2))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
if (nz.gt.nz2 ) then
itmp = nz
nz = nz2
nz2 = itmp
endif
if ( ( nz.ne.19 ).or.(nz2.ne.24) ) then
print*,' ERROR: grid inconsitence... level vs level_2'
print*,'nz,nz2 ',nz,nz2
stop
endif
do i=1,nz
if ( abs( lev2(i)-lev(i) ).gt.eps ) then
print*,' ERROR: grid inconsitence... level vs level_2'
print*,i,lev2(i),lev(i)
stop
endif
enddo
c Set the final (expected) parameters, including closing and shifting
nx = 181
ny = 91
nz = 19
xmin = -180.
xmax = 180.
ymin = -90.
ymax = 90.
dx = 2.
dy = 2.
pollon = 0.
pollat = 90.
stagz = 0.
c Get non-constant grid parameters (surface pressure and vertical grid)
else
c Set 3D pressure
ierr = NF90_INQ_VARID(fid,'level_2',varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(fid,varid,lev(1:nz))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
do i=1,nx
do j=1,ny
do k=1,nz
p3(i,j,k) = lev(k)
enddo
enddo
enddo
c Set ak, bk
do k=1,nz
ak(k) = lev(k)
bk(k) = 0.
enddo
c Read surface pressure (close and shift/swap domain; unit conversion)
varname = 'pres'
ierr = NF90_INQ_VARID(fid,varname,varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(fid,varid,tmp(1:(nx-1),1:ny))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
do i=1,nx-1
lon1 = xmin + real(i-1)*dx
if ( lon1.lt.-eps ) lon1 = lon1 + 360.
indx = nint( lon1 / dx + 1. )
do j=1,ny
ps(i,j) = 0.01 * tmp(indx,ny-j+1)
enddo
enddo
do j=1,ny
ps(nx,j) = ps(1,j)
enddo
endif
end
c ------------------------------------------------------------
c Read wind and other met field
c ------------------------------------------------------------
subroutine input_wind (fid,fieldname,field,time,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,
> timecheck)
use netcdf
c Read the wind component <fieldname> from the file with identifier
c <fid> and save it in the 3d array <field>. The vertical staggering
c information is provided in <stagz> and gives the reference to either
c the layer or level field from <input_grid>. A consistency check is
c performed to have an agreement with the grid specified by <xmin,xmax,
c ymin,ymax,dx,dy,nx,ny,nz>.
implicit none
c Declaration of variables and parameters
integer fid ! File identifier
character*80 fieldname ! Name of the wind field
integer nx,ny,nz ! Dimension of fields
real field(nx,ny,nz) ! 3d wind field
real stagz ! Staggering in the z direction
real mdv ! Missing data flag
real xmin,xmax,ymin,ymax ! Domain size
real dx,dy ! Horizontal resolution
real time ! Time
character*80 timecheck ! Either 'yes' or 'no'
c Netcdf variables
integer ierr
character*80 varname
character*80 newname
c Numerical epsilon
real eps
parameter (eps=0.0001)
c Auxiliary variables
integer i,j,k
real lev(1000)
integer varid
real tmp(nx-1,ny,nz)
real lon(nx-1)
integer indx
real lon1
integer is2d
c Set the correct fieldname
newname = fieldname
if ( fieldname.eq.'PLEV' ) newname='P'
if ( fieldname.eq.'PLAY' ) newname='P'
if ( fieldname.eq.'P' ) newname='P'
if ( fieldname.eq.'OMEGA' ) newname='omega'
if ( fieldname.eq.'PS' ) newname='pres'
if ( fieldname.eq.'U' ) newname='uwnd'
if ( fieldname.eq.'V' ) newname='vwnd'
c Get flag for 2D field
is2d = 0
if ( fieldname.eq.'pres' ) is2d = 1
c Get 3D pressure
if ( fieldname.eq.'P' ) then
varname = 'level'
ierr = NF90_INQ_VARID(fid,varname,varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(fid,varid,lev(1:nz))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
do i=1,nx
do j=1,ny
do k=1,nz
field(i,j,k) = lev(k)
enddo
enddo
enddo
mdv = -9.96921e+36
c Get 3D field (close and shift/swap domain)
elseif ( is2d.eq.0 ) then
varname = newname
ierr = NF90_INQ_VARID(fid,varname,varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(fid,varid,tmp(1:(nx-1),1:ny,1:nz))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_get_att(fid, varid, "_FillValue", mdv)
IF (ierr /= nf90_NoErr) THEN
mdv = -9.96921e+36
ierr = nf90_NoErr
ENDIF
do i=1,nx-1
lon1 = xmin + real(i-1)*dx
if ( lon1.lt.-eps ) lon1 = lon1 + 360.
indx = nint( lon1 / dx + 1. )
do k=1,nz
do j=1,ny
field(i,j,k) = tmp(indx,ny-j+1,k)
enddo
field(nx,j,k) = field(1,j,k)
enddo
enddo
c Get 2D field (close and shift/swap domain)
elseif ( is2d.eq.1 ) then
varname = newname
ierr = NF90_INQ_VARID(fid,varname,varid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = NF90_GET_VAR(fid,varid,tmp(1:(nx-1),1:ny,1:1))
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
ierr = nf90_get_att(fid, varid, "_FillValue", mdv)
IF (ierr /= nf90_NoErr) THEN
mdv = -9.96921e+36
ierr = nf90_NoErr
ENDIF
do i=1,nx-1
lon1 = xmin + real(i-1)*dx
if ( lon1.lt.-eps ) lon1 = lon1 + 360.
indx = nint( lon1 / dx + 1. )
do j=1,ny
field(i,j,1) = tmp(indx,ny-j+1,1)
do k=2,nz
field(i,j,k) = field(i,j,k-1)
enddo
field(nx,j,k) = field(1,j,k)
enddo
enddo
endif
end
c ------------------------------------------------------------
c Close input file
c ------------------------------------------------------------
subroutine input_close(fid)
c Close the input file with file identifier <fid>.
use netcdf
implicit none
c Declaration of subroutine parameters
integer fid
c Auxiliary variables
integer ierr
ierr = NF90_CLOSE(fid)
IF( ierr /= nf90_NoErr) PRINT *,NF90_STRERROR(ierr)
end

/tags/1.0/lib/iotra.f
0,0 → 1,810
c ****************************************************************
c * This package provides IO routines for trajectories. A file *
c * is characterised by the filename <filename> and the file *
c * identifier <fid>. Different modes <mode> are supported: *
c * mode=1: ascii, sorted by trajectory; *
c * mode=2: ascii, sorted by time; *
c * mode=3: fortran (unformatted) *
c * mode=4: IVE netcdf (for compatibiltzy reasons) *
c * A trajectory set is given as 3d array <tra(ntra,ntim,ncol)> *
c * where <ntra> is the number of trajectories, <ntim> the *
c * number of times of each trajectory and <ncol> the number of *
c * columns of the trajectory. The first 4 columns are: time, *
c * longitude, latitude, pressure. The other columns are traced *
c * fields. The complete list of all columns is given in the *
c * array <vars(ncol)>. Finally, the reference date is given in *
c * the array <time(6)=year,month,day,hour,time length of the *
c * trajectory (hour,min)>. *
c * *
c * Author: Michael Sprenger, September 2008 *
c ****************************************************************
c ----------------------------------------------------------------
c Open a trajectory file for reading
c ----------------------------------------------------------------
subroutine ropen_tra(fid,filename,ntra,ntim,ncol,time,vars,mode)
implicit none
c Declaration of subroutine parameters
integer fid
character*80 filename
integer mode
integer ntra,ntim,ncol
integer time(6)
character*80 vars(ncol)
c Auxiliary variables
integer vardim(4)
real varmin(4),varmax(4),stag(4)
real mdv
character*80 cfn
integer ierr
integer i
integer nvars
c Open file
if (mode.eq.1) then
fid = 10
open(fid,file=filename)
elseif (mode.eq.2) then
fid = 10
open(fid,file=filename)
elseif (mode.eq.3) then
open(fid,file=filename,form='unformatted')
elseif (mode.eq.4) then
call cdfopn(filename,fid,ierr)
elseif (mode.eq.5) then
print*,' ERROR: Reading KML not supported'
stop
endif
c Read header information
call read_hea(fid,time,vars,ntra,ntim,ncol,mode)
end
c ----------------------------------------------------------------
c Open a trajectory file for wrinting
c ----------------------------------------------------------------
subroutine wopen_tra(fid,filename,ntra,ntim,ncol,time,vars,mode)
implicit none
c Declaration of subroutine parameters
integer fid
character*80 filename
integer mode
integer ntra,ntim,ncol
integer time(6)
character*80 vars(ncol)
c Auxiliary variables
integer vardim(4)
real varmin(4),varmax(4),stag(4)
real mdv
character*80 cfn
integer ierr
integer i
character*80 varname
real rtime(6)
c Open file
if (mode.eq.1) then
fid = 10
open(fid,file=filename)
elseif (mode.eq.2) then
fid = 10
open(fid,file=filename)
elseif (mode.eq.3) then
open(fid,file=filename,form='unformatted')
elseif (mode.eq.4) then
vardim(1)=ntra
vardim(2)=1
vardim(3)=1
vardim(4)=1
cfn =trim(filename)//'_cst'
mdv =-999.98999
call crecdf(filename,fid,varmin,varmax,3,cfn,ierr)
elseif (mode.eq.5) then
fid = 10
open(fid,file=filename)
endif
c Write header information
call write_hea(fid,time,vars,ntra,ntim,ncol,mode)
end
c ----------------------------------------------------------------
c Read a trajectory
c ----------------------------------------------------------------
subroutine read_tra(fid,tra,ntra,ntim,ncol,mode)
implicit none
c Declaration of subroutine parameters
integer fid
integer ntim
integer ncol
integer ntra
real tra(ntra,ntim,ncol)
integer mode
c Auxiliary variables
integer i,j,n
real arr(ntra)
integer ntimes
real times(1000)
integer ierr
character*80 vars(ncol+2)
integer nvars
c Read ascii mode, sorted by trajectory (mode=1)
if (mode.eq.1) then
read(fid,*,end=100)
do n=1,ntra
do i=1,ntim
read(fid,*,end=110) (tra(n,i,j),j=1,ncol)
enddo
enddo
c Read ascii mode, sorted by time (mode=2)
elseif (mode.eq.2) then
read(fid,*,end=100)
do i=1,ntim
do n=1,ntra
read(fid,*,end=100) (tra(n,i,j),j=1,ncol)
enddo
enddo
c Read fortran mode (mode=3)
elseif (mode.eq.3) then
read(fid) tra
c Read IVE netcdf mode (mode=4)
elseif (mode.eq.4) then
call gettimes(fid,times,ntimes,ierr)
call getvars(fid,nvars,vars,ierr)
do i=1,ntim
do j=1,ncol
if (j.eq.1) then
do n=1,ntra
tra(n,i,1)=times(i)
enddo
else
call getdat(fid,vars(j),times(i),0,arr,ierr)
do n=1,ntra
tra(n,i,j)=arr(n)
enddo
endif
enddo
enddo
endif
return
c End of file has been reached: set negative <fid>
100 fid=-fid
return
c Error: incomplete trajectory
110 print*,'<read_tra>: Incomplete trajectory... Stop'
stop
end
c ----------------------------------------------------------------
c Write a trajectory
c ----------------------------------------------------------------
subroutine write_tra(fid,tra,ntra,ntim,ncol,mode)
implicit none
c Declaration of subroutine parameters
integer fid
integer ntim
integer ncol
integer ntra
real tra(ntra,ntim,ncol)
integer mode
c Auxiliary variables
integer i,j,n
real arr(ntra)
integer ierr
real time
character*80 vars(ncol+2)
integer nvars
character*20 lonstr,latstr,levstr
character*80 outstr
real ref_z(3000),ref_p(3000),ref_t(3000)
real lev
character*80 path
c Write ascii mode, sorted by trajectory (mode=1)
if (mode.eq.1) then
do n=1,ntra
write(fid,*)
do i=1,ntim
c Avoid ugly *s or missing space in output
do j=5,ncol
if ( abs(tra(n,i,j)).gt.9999.) then
print*,'Format problem : ',tra(n,i,j),' -> -999.99'
tra(n,i,j) = -999.99
endif
enddo
write(fid,'(1f7.2,f9.2,f8.2,i6,100f10.3)')
> (tra(n,i,j),j=1,3), ! time, lon, lat
> nint(tra(n,i,4)), ! p
> (tra(n,i,j),j=5,ncol) ! fields
enddo
enddo
c Write ascii mode, sorted by time (mode=2)
elseif (mode.eq.2) then
do i=1,ntim
write(fid,*)
do n=1,ntra
c Avoid ugly *s or missing space in output
do j=5,ncol
if ( abs(tra(n,i,j)).gt.9999.) then
print*,'Format problem : ',tra(n,i,j),' -> -999.99'
tra(n,i,j) = -999.99
endif
enddo
write(fid,'(1f7.2,f9.2,f8.2,i6,100f10.3)')
> (tra(n,i,j),j=1,3), ! time, lon, lat
> nint(tra(n,i,4)), ! p
> (tra(n,i,j),j=5,ncol) ! fields
enddo
enddo
c Write fortran mode (mode=3)
elseif (mode.eq.3) then
write(fid) tra
c Write netcdf mode (mode=4)
elseif (mode.eq.4) then
call getvars(fid,nvars,vars,ierr)
do i=1,ntim
time=tra(1,i,1)
do j=2,ncol
do n=1,ntra
arr(n)=tra(n,i,j)
enddo
call putdat(fid,vars(j),time,0,arr,ierr)
enddo
enddo
c Write KML mode (mode=5)
elseif (mode.eq.5) then
call getenv('DYN_TOOLS',path)
path = trim(path)//'/lagranto.ecmwf/goodies/'
open(fid+1,file=trim(path)//'reformat.refprof')
do n=1,6
read(fid+1,*)
enddo
do n=1,3000
read(fid+1,*) ref_z(n),ref_t(n),ref_p(n)
ref_p(n) = 0.01 * ref_p(n)
enddo
close(fid+1)
do n=1,ntra
write(fid,"(A)") '<Placemark>'
write(fid,"(A)") '<name>Absolute Extruded</name>'
write(fid,"(A)") '<styleUrl>#yellowkLineGreenPoly</styleUrl>'
write(fid,"(A)") '<LineString>'
write(fid,"(A)") '<extrude>1</extrude>'
write(fid,"(A)") '<tessellate>1</tessellate>'
write(fid,"(A)") '<altitudeMode>absolute</altitudeMode>'
write(fid,"(A)") '<coordinates>'
do i=1,ntim
write(lonstr,*) tra(n,i,2)
write(latstr,*) tra(n,i,3)
call binary(lev,tra(n,i,4),ref_z,ref_p)
write(levstr,*) lev
outstr = trim(adjustl(lonstr))//','//
> trim(adjustl(latstr))//','//
> trim(adjustl(levstr))
write(fid,"(A)") outstr
enddo
write(fid,*) '</coordinates>'
write(fid,*) '</LineString>'
write(fid,*) '</Placemark>'
enddo
endif
end
c ----------------------------------------------------------------
c Read header from trajectory file
c ----------------------------------------------------------------
subroutine read_hea(fid,time,vars,ntra,ntim,ncol,mode)
implicit none
c Declaration of subroutine parameters
integer fid
integer time(6)
integer ntra,ntim,ncol
character*80 vars(ncol)
integer mode
c Auxiliary variables
integer i
character ch(500)
character*500 str
integer ich(500)
integer isstr,ileft,iright
character*80 varname
real rtime(6)
integer ierr
integer nvars
character*15 str1
character str2
character*13 str3
character*4 str4
character*80 linestr
integer itmp1,itmp2
c Read ascii format (mode=1,2)
if ( (mode.eq.1).or.(mode.eq.2) ) then
c Read the time specification (old and new format)
read(fid,'(a80)') linestr
if ( linestr(1:14).eq.'Reference date' ) then
read(linestr,'(a15,i4,i2,i2,a1,i2,i2,a13,i8,a4)')
> str1,
> time(1),time(2),time(3),str2,time(4),time(5),
> str3,time(6),str4
elseif ( linestr(1:11).eq.'time period' ) then
read(linestr,'(a12,i4,i2,i2,a1,i2,a4,i6,a1,i2,a2)')
> str1,
> time(1),time(2),time(3),str2,time(4),
> str3,itmp1,str3,itmp2,str4
time(5) = 0
time(6) = itmp1 * 60 + itmp2
endif
c Skip the empty line and read field names
read(fid,*)
read(fid,'(a500)',end=100) str
do i=1,500
ch(i)=str(i:i)
enddo
c Split the input string
isstr=0
nvars=0
do i=1,500
if ( (isstr.eq.0).and.(ch(i).ne.' ') ) then
isstr=1
ileft=i
elseif ( (isstr.eq.1).and.(ch(i).eq.' ') ) then
isstr=0
iright=i-1
nvars=nvars+1
vars(nvars)=str(ileft:iright)
endif
enddo
c Skip the empty line
read(fid,*,end=100)
c Read fortran mode (mode=3)
elseif (mode.eq.3) then
read(fid) ntra,ntim,ncol
read(fid) time
read(fid) vars
c Read IVE netcdf mode (mode=4)
elseif (mode.eq.4) then
call getvars(fid,nvars,vars,ierr)
varname='BASEDATE'
call getdat(fid,varname,0.,0,rtime,ierr)
do i=1,6
time(i)=nint(rtime(i))
enddo
endif
return
c End of file has been reached
100 fid=-fid
return
c Excetion handling
110 print*,'<read_hea>: Unexspected time format.... Stop'
stop
end
c ----------------------------------------------------------------
c Write header to trajectory file (in ascii mode)
c ----------------------------------------------------------------
subroutine write_hea(fid,time,vars,ntra,ntim,ncol,mode)
implicit none
c Declaration of subroutine parameters
integer fid
integer time(6)
integer ntra,ntim,ncol
character*80 vars(ncol)
integer mode
c Auxiliary variables
integer i
character*500 str
character*4 str1
character*2 str2,str3,str4,str5,str6
integer vardim(4)
real varmin(4),varmax(4),stag(4)
real mdv
integer ierr
character*80 varname
real rtime(6)
integer nvars
c Write ascii format (mode=1,2)
if ( (mode.eq.1).or.(mode.eq.2) ) then
c Get the strings for output
write(str1,'(i4)') time(1)
write(str2,'(i2)') time(2)
write(str3,'(i2)') time(3)
write(str4,'(i2)') time(4)
write(str5,'(i2)') time(5)
if (time(2).eq. 0) str2(1:1)='0'
if (time(3).eq. 0) str3(1:1)='0'
if (time(4).eq. 0) str4(1:1)='0'
if (time(5).eq. 0) str5(1:1)='0'
if (time(2).lt.10) str2(1:1)='0'
if (time(3).lt.10) str3(1:1)='0'
if (time(4).lt.10) str4(1:1)='0'
if (time(5).lt.10) str5(1:1)='0'
c Write the time specification
write(fid,'(a15,a4,a2,a2,a1,a2,a2,a13,i8,a4)')
> 'Reference date ',
> str1,str2,str3,'_',str4,str5,
> ' / Time range',time(6), ' min'
write(fid,*)
c Write variable names
str=''
do i=1,ncol
str=trim(str)//trim(vars(i))
enddo
write(fid,'(a6,a9,a8,a6,100a10)') (trim(vars(i)),i=1,ncol)
write(fid,'(a6,a9,a8,a6,100a10)')
> '------','---------','--------','------',
> ('----------',i=5,ncol)
c Write fortran mode (mode=3)
elseif (mode.eq.3) then
write(fid) ntra,ntim,ncol
write(fid) time
write(fid) vars
c Write IVE netcdf format (mode=4)
elseif (mode.eq.4) then
vardim(1)=ntra
vardim(2)=1
vardim(3)=1
vardim(4)=1
mdv =-999.98999
do i=2,ncol
call putdef(fid,vars(i),4,mdv,vardim,
> varmin,varmax,stag,ierr)
enddo
varname='BASEDATE'
vardim(1)=6
call putdef(fid,varname,4,mdv,vardim,
> varmin,varmax,stag,ierr)
do i=1,6
rtime(i)=real(time(i))
enddo
call putdat(fid,varname,0.,0,rtime,ierr)
c Write KML format (mode=5)
elseif (mode.eq.5) then
write(fid,"(A)") '<?xml version="1.0" encoding="UTF-8"?>'
write(fid,"(A)") '<kml xmlns="http://www.opengis.net/kml/2.2">'
write(fid,"(A)") '<Document>'
write(fid,"(A)") '<name>Paths</name>'
write(fid,"(A)") '<Style id="yellowLineGreenPoly">'
write(fid,"(A)") '<LineStyle>'
c write(fid,*) '<color>7f00ffff</color>' ! Yellow
write(fid,"(A)") '<color>500A0A0A</color>' ! Black
write(fid,"(A)") '<width>4</width>'
write(fid,"(A)") '</LineStyle>'
write(fid,"(A)") '<PolyStyle>'
write(fid,"(A)") '<color>7f00ff00</color>'
write(fid,"(A)") '</PolyStyle>'
write(fid,"(A)") '</Style>'
endif
end
c ----------------------------------------------------------------
c Close a trajectory file
c ----------------------------------------------------------------
subroutine close_tra(fid,mode)
implicit none
c Declaration of subroutine parameters
integer fid
integer mode
c Auxiliary variables
integer ierr
c Close file
if (mode.eq.1) then
close(abs(fid))
elseif (mode.eq.2) then
close(abs(fid))
elseif (mode.eq.3) then
close(fid)
elseif (mode.eq.4) then
call clscdf(fid,ierr)
elseif (mode.eq.5) then
write(fid,"(A)") '</Document>'
write(fid,"(A)") '</kml>'
close(abs(fid))
endif
end
c ----------------------------------------------------------------
c Determine the mode of a trajectory file
c ----------------------------------------------------------------
subroutine mode_tra(mode,filename)
implicit none
c Declaration of subroutine parameters
integer mode
character*80 filename
c Auxiliary variables
integer len
character char0,char1,char2,char3,char4
c Get mode
mode=-1
len = len_trim(filename)
c Mode specified by number
char0 = filename((len-1):(len-1))
char1 = filename(len:len)
if ( (char0.eq.'.').and.(char1.eq.'1') ) mode=1
if ( (char0.eq.'.').and.(char1.eq.'2') ) mode=2
if ( (char0.eq.'.').and.(char1.eq.'3') ) mode=3
if ( (char0.eq.'.').and.(char1.eq.'4') ) mode=4
if ( (char0.eq.'.').and.(char1.eq.'5') ) mode=5
if ( mode.gt.0 ) return
c Mode specified by appendix
char0 = filename((len-3):(len-3))
char1 = filename((len-2):(len-2))
char2 = filename((len-1):(len-1))
char3 = filename(len:len)
if ( (char1.eq.'.').and.(char2.eq.'l').and.(char3.eq.'s') ) mode=1
if ( (char1.eq.'.').and.(char2.eq.'t').and.(char3.eq.'i') ) mode=2
if ( (char1.eq.'.').and.(char2.eq.'d').and.(char3.eq.'u') ) mode=3
if ( (char1.eq.'.').and.(char2.eq.'n').and.(char3.eq.'c') ) mode=4
if ( (char0.eq.'.').and.(char1.eq.'k').and.
> (char2.eq.'m').and.
> (char3.eq.'l') ) mode = 5
end
c ----------------------------------------------------------------
c Get dimension of a trajectory file
c ----------------------------------------------------------------
subroutine info_tra(filename,ntra,ntim,ncol,mode)
implicit none
c Declaration of subroutine parameters
integer fid
character*80 filename
integer mode
integer ntra,ntim,ncol
c Auxiliary variables
integer vardim(4)
real varmin(4),varmax(4),stag(4)
real mdv
character*80 cfn
integer ierr
integer i,ndim
character*80 vars(100)
integer nvars
integer ntimes
real times(100)
character*500 str
integer nline0,nline1,nline2
integer isstr,isok
character ch
c Open file
if (mode.eq.1) then
fid=10
open(fid,file=filename)
elseif (mode.eq.2) then
fid=10
open(fid,file=filename)
elseif (mode.eq.3) then
fid=10
open(fid,file=filename,form='unformatted')
elseif (mode.eq.4) then
call cdfopn(filename,fid,ierr)
endif
c Get dimension information
if ( (mode.eq.1).or.(mode.eq.2) ) then
read(fid,*)
read(fid,*)
read(fid,'(a500)') str
read(fid,*)
c Get the number of columns
isstr=0
ncol =0
do i=1,500
ch = str(i:i)
if ( (isstr.eq.0).and.(ch.ne.' ') ) then
isstr=1
elseif ( (isstr.eq.1).and.(ch.eq.' ') ) then
isstr=0
ncol=ncol+1
endif
enddo
c Get the first data block
nline0 = 5
nline1 = 5
read(fid,*)
100 read(fid,'(a500)',end=110) str
if (str.ne.'') then
nline1 = nline1 + 1
goto 100
endif
110 continue
c Get the total numbers of lines in the data block
nline2 = nline1
120 read(fid,*,end=130)
nline2 = nline2 + 1
goto 120
130 nline2 = nline2 + 1
c Set the dimensions
if (mode.eq.1) then
ntim = nline1 - nline0
ntra = (nline2-nline0+1)/(ntim+1)
else
ntra = nline1 - nline0
ntim = (nline2-nline0+1)/(ntra+1)
endif
elseif (mode.eq.3) then
read(fid) ntra,ntim,ncol
elseif (mode.eq.4) then
call gettimes(fid,times,ntimes,ierr)
call getvars(fid,nvars,vars,ierr)
call getdef(fid,trim(vars(2)),ndim,mdv,vardim,
> varmin,varmax,stag,ierr)
ntra = vardim(1)
ntim = ntimes
ncol = nvars-1
endif
c Close file
if (mode.eq.1) then
close(fid)
elseif (mode.eq.2) then
close(fid)
elseif (mode.eq.3) then
close(fid)
elseif (mode.eq.4) then
call clscdf(fid,ierr)
endif
end
c ----------------------------------------------------------------
c Binary search algorithm
c ----------------------------------------------------------------
subroutine binary (z,p,ref_z,ref_p)
implicit none
c Declaration of subroutine parameters
real z
real p
real ref_z(3000)
real ref_p(3000)
c Auxiliary variables
integer i0,i1,im
c Binary search
i0 = 1
i1 = 3000
100 continue
im = (i0 + i1) / 2
if ( p.lt.ref_p(im) ) then
i0 = im
else
i1 = im
endif
if ( (i1-i0).gt.1 ) goto 100
c Linear interpolation in between
z = ref_z(i0) + ( p - ref_p(i0) ) / ( ref_p(i1) - ref_p(i0) ) *
> ( ref_z(i1) - ref_z(i0) )
end

/tags/1.0/lib/libcdfio.f
0,0 → 1,1601
subroutine clscdf (cdfid, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine closes an open netCDF file.
c Aguments :
c cdfid int input the id of the file to be closed.
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer cdfid, error
c Local variable declarations.
integer ncopts
c Get current value of error options.
call ncgopt (ncopts)
c Make sure netCDF errors do not abort execution.
call ncpopt (NCVERBOS)
c Close requested file.
call ncclos (cdfid, error)
c Reset error options.
call ncpopt (ncopts)
end
subroutine crecdf (filnam, cdfid, phymin, phymax, ndim, cfn,
& error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to create a netCDF file for use with
c the UWGAP plotting package.
c Any netCDF file written to must be closed with the call
c 'call clscdf(cdfid,error)', where cdfid and error are
c as in the argumentlist below.
c Arguments:
c filnam char input the user-supplied netCDF file name.
c cdfid int output the file-identifier
c phymin real input the minimum physical dimension of the
c entire physical domain along each axis.
c phymin is dimensioned (ndim)
c phymax real input the maximum physical dimension of the
c entire physical domain along each axis.
c phymax is dimensioned (ndim)
c ndim int input the number of dimensions in the file
c (i.e. number of elements in phymin,
c phymax)
c cfn char input constants file name
c ('0' = no constants file).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created cr3df.
c Jan. 92 CS UW Created crecdf.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
integer ndim, error
character *(*) filnam,cfn
real phymin(*), phymax(*)
c Local variable declarations.
character *(20) attnam
character *(1) chrid(MAXDIM)
integer cdfid, k, ibeg, iend, lenfil, ncopts
data chrid/'x','y','z','a'/
c Get current value of error options, and make sure netCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c create the netCDF file
cdfid = nccre (trim(filnam), NCCLOB, error)
if (error.ne.0) go to 920
c define global attributes
do k=1,ndim
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='min'
attnam=attnam(1:7)
call ncapt(cdfid,NCGLOBAL,attnam,NCFLOAT,1,phymin(k),error)
if (error.gt.0) goto 920
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='max'
attnam=attnam(1:7)
call ncapt(cdfid,NCGLOBAL,attnam,NCFLOAT,1,phymax(k),error)
if (error.gt.0) goto 920
enddo
c define constants file name
if (cfn.ne.'0') then
call ncaptc (cdfid, NCGLOBAL, 'constants_file_name',
c & NCCHAR, len_trim(cfn)+1, cfn // char(0) , error)
& NCCHAR, len_trim(cfn), cfn , error)
if (error.gt.0) goto 920
endif
c End variable definitions.
call ncendf (cdfid, error)
if (error.gt.0) goto 920
c normal exit
call ncpopt (ncopts)
return
c error exit
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'create the data file in subroutine crecdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
end
subroutine opncdf(filnam, cdfid,
& phymin, phymax, ndim, varnam, nvar, cfn, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to open a netCDF file for read and write
c with the UWGAP plotting package.
c Arguments:
c filnam char input the user-supplied netCDF file name.
c cdfid int output the file-identifier
c phymin real output the minimum physical dimension of the
c entire physical domain along each axis.
c phymin is dimensioned (ndim)
c phymax real output the maximum physical dimension of the
c entire physical domain along each axis.
c phymax is dimensioned (ndim)
c ndim int output the number of dimensions in the file
c (i.e. number of elements in phymin,
c phymax)
c varnam char output an array containing the variable names.
c varnam is dimensioned (nvar).
c nvar int output the number of variables in the file
c cfn char output constants file name
c ('0'=no constants file).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created cr3df.
c Jan. 92 CS UW Created opncdf.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
integer ndim, nvar, error
character *(*) filnam, varnam(*),cfn
real phymin(*), phymax(*)
c Local variable declarations.
character *(20) attnam,vnam
character *(1) chrid(MAXDIM)
integer cdfid, i,k
integer ncopts, ndims,ngatts,recdim
integer nvdims,vartyp,nvatts,vardim(MAXDIM)
real attval
integer lenstr
data chrid/'x','y','z','a'/
data lenstr/80/
c Get current value of error options and make sure netCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c open the netCDF file for write
cdfid = ncopn (trim(filnam), NCWRITE, error)
if (error.ne.0) then
c try to open the netCDF file for read
cdfid = ncopn (trim(filnam), NCNOWRIT, error)
if (error.ne.0) go to 920
endif
c inquire for number of variables
call ncinq(cdfid,ndims,nvar,ngatts,recdim,error)
if (error.eq.1) goto 920
c read the variables
do i=1,nvar
call ncvinq(cdfid,i,varnam(i),vartyp,nvdims,vardim,
& nvatts,error)
if (vartyp.ne.NCFLOAT) error=1
if (error.gt.0) goto 920
enddo
c get global attributes
k=0
100 continue
k=k+1
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='min'
attnam=attnam(1:7)
c switch off error message
call ncpopt(0)
c check whether dimension k is present
call ncagt(cdfid,NCGLOBAL,attnam,attval,error)
if (error.gt.0) goto 110
phymin(k)=attval
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='max'
attnam=attnam(1:7)
call ncagt(cdfid,NCGLOBAL,attnam,attval,error)
if (error.gt.0) goto 920
phymax(k)=attval
if (k.lt.3) goto 100
k=k+1
c define ndim-parameter
110 continue
ndim=k-1
error=0
c switch on error messages
call ncpopt(NCVERBOS)
c get constants file name
c call ncagt(cdfid,NCGLOBAL,'constants_file_name',cfn,error)
c ! chrigel
call ncagtc(cdfid,NCGLOBAL,'constants_file_name',cfn,lenstr,error)
if (error.gt.0) cfn='0'
c normal exit
call ncpopt (ncopts)
return
c error exit
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'read the data file in subroutine opncdf.'
call ncclos (cdfid, error)
call ncpopt (ncopts)
end
subroutine readcdf(filnam, cdfid,
& phymin, phymax, ndim, varnam, nvar, cfn, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to open a netCDF file for read
c with the UWGAP plotting package.
c Arguments:
c filnam char input the user-supplied netCDF file name.
c cdfid int output the file-identifier
c phymin real output the minimum physical dimension of the
c entire physical domain along each axis.
c phymin is dimensioned (ndim)
c phymax real output the maximum physical dimension of the
c entire physical domain along each axis.
c phymax is dimensioned (ndim)
c ndim int output the number of dimensions in the file
c (i.e. number of elements in phymin,
c phymax)
c varnam char output an array containing the variable names.
c varnam is dimensioned (nvar).
c nvar int output the number of variables in the file
c cfn char output constants file name
c ('0'=no constants file).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created cr3df.
c Jan. 92 CS UW Created opncdf.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
integer ndim, nvar, error
character *(*) filnam, varnam(*),cfn
real phymin(*), phymax(*)
c Local variable declarations.
character *(20) attnam
character *(1) chrid(MAXDIM)
integer cdfid, i,k
integer ncopts, ndims,ngatts,recdim
integer nvdims,vartyp,nvatts,vardim(MAXDIM)
real attval
integer lenstr
data chrid/'x','y','z','a'/
data lenstr/80/
c Get current value of error options.
call ncgopt (ncopts)
c make sure netCDF-errors do not abort execution
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c open the netCDF file for read
cdfid = ncopn (trim(filnam), NCNOWRIT, error)
if (error.ne.0) go to 920
c inquire for number of variables
call ncinq(cdfid,ndims,nvar,ngatts,recdim,error)
if (error.eq.1) goto 920
c read the variables
do i=1,nvar
call ncvinq(cdfid,i,varnam(i),vartyp,nvdims,vardim,
& nvatts,error)
if (vartyp.ne.NCFLOAT) error=1
c print *,varnam(i),nvdims,nvatts
if (error.gt.0) goto 920
enddo
c get global attributes
k=0
100 continue
k=k+1
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='min'
attnam=attnam(1:7)
c switch off error message
call ncpopt(0)
c check whether dimension k is present
call ncagt(cdfid,NCGLOBAL,attnam,attval,error)
if (error.gt.0) goto 110
phymin(k)=attval
attnam(1:3)='dom'
attnam(4:4)=chrid(k)
attnam(5:7)='max'
attnam=attnam(1:7)
call ncagt(cdfid,NCGLOBAL,attnam,attval,error)
if (error.gt.0) goto 920
phymax(k)=attval
if (k.lt.4) goto 100
k=k+1
c define ndim-parameter
110 continue
ndim=k-1
error=0
c switch on error messages
call ncpopt(NCVERBOS)
c get constants file name
c call ncagt(cdfid,NCGLOBAL,'constants_file_name',cfn,error)
c ! chrigel
call ncagtc(cdfid,NCGLOBAL,'constants_file_name',cfn,lenstr,error)
if (error.gt.0) cfn='0'
c print *,cfn
c normal exit
call ncpopt (ncopts)
return
c error exit
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'read the data file in subroutine opncdf.'
call ncclos (cdfid, error)
call ncpopt (ncopts)
end
subroutine getcdf (cdfid, varnam, ndim, misdat,
& vardim, varmin, varmax, stag, dat, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to get a variable and its attributes
c from a netCDF file for use with the UWGAP plotting package.
c It is assumed that the data is floating-point data. Prior to
c calling this routine, the file must be opened with a call to
c opncdf.
c Arguments:
c cdfid int input file-identifier
c (can be obtained by calling routine
c opncdf)
c varnam char input the user-supplied variable name.
c (can be obtained by calling routine
c opncdf)
c ndim int output the number of dimensions (ndim<=4)
c misdat real output missing data value for the variable.
c vardim int output the dimensions of the variable.
c is dimensioned at least (ndim).
c varmin real output the location in physical space of the
c origin of each variable.
c is dimensioned at least Min(ndim,3).
c varmax real output the extent of each variable in physical
c space.
c is dimensioned at least Min(ndim,3).
c stag real output the grid staggering for each variable.
c is dimensioned at least Min(ndim,3).
c dat real output data-array dimensioned suffiecently
c large, at least
c vardim(1)* ... vardim(ndim)
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created cr3df.
c Jan. 92 CS UW Created getcdf.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
character *(*) varnam
integer vardim(*), ndim, error, cdfid
real misdat, stag(*), varmin(*), varmax(*), dat(*)
c Local variable declarations.
character *(20) dimnam(100),attnam
character *(1) chrid(MAXDIM)
integer id,i,k,corner(MAXDIM)
integer ndims,nvars,ngatts,recdim,dimsiz(100)
integer vartyp,nvatts, ncopts
data chrid/'x','y','z','a'/
data corner/1,1,1,1/
c Get current value of error options, and make sure netCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c inquire for number of dimensions
call ncinq(cdfid,ndims,nvars,ngatts,recdim,error)
if (error.eq.1) goto 920
c read dimension-table
do i=1,ndims
call ncdinq(cdfid,i,dimnam(i),dimsiz(i),error)
if (error.gt.0) goto 920
enddo
c get id of the variable
id=ncvid(cdfid,varnam,error)
if (error.eq.1) goto 910
c inquire about variable
call ncvinq(cdfid,id,varnam,vartyp,ndim,vardim,nvatts,error)
if (vartyp.ne.NCFLOAT) error=1
if (error.gt.0) goto 920
c Make sure ndim <= MAXDIM.
if (ndim.gt.MAXDIM) then
error = 1
go to 900
endif
c get dimensions from dimension-table
do k=1,ndim
vardim(k)=dimsiz(vardim(k))
enddo
c get attributes
do k=1,min0(ndim,3)
c get staggering
attnam(1:1)=chrid(k)
attnam(2:5)='stag'
attnam=attnam(1:5)
call ncagt(cdfid,id,attnam,stag(k),error)
if (error.gt.0) goto 920
c get min postion
attnam(1:1)=chrid(k)
attnam(2:4)='min'
attnam=attnam(1:4)
call ncagt(cdfid,id,attnam,varmin(k),error)
if (error.gt.0) goto 920
c get max position
attnam(1:1)=chrid(k)
attnam(2:4)='max'
attnam=attnam(1:4)
call ncagt(cdfid,id,attnam,varmax(k),error)
if (error.gt.0) goto 920
enddo
c get missing data value
call ncagt(cdfid,id,'missing_data',misdat,error)
if (error.gt.0) goto 920
c get data
call ncvgt(cdfid,id,corner,vardim,dat,error)
if (error.gt.0) goto 920
c normal exit
call ncpopt (ncopts)
return
c Error exits.
900 write (6, *) 'ERROR: When calling getcdf, the number of ',
& 'variable dimensions must be less or equal 4.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
910 write (6, *) 'ERROR: The selected variable could not be found ',
& 'in the file by getcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'read the data file in subroutine getcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
end
subroutine putcdf (cdfid, varnam, ndim, misdat,
& vardim, varmin, varmax, stag, dat, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to put a variable and its attributes
c onto a netCDF file for use with the UWGAP plotting package.
c It is assumed that the data is floating-point data. Prior to
c calling this routine, the file must be created (crecdf) or
c opened (opncdf).
c Any netCDF file written to must be closed with the call
c call ncclos(cdfid,error), where cdfid and error are
c as in the argumentlist below.
c Arguments:
c cdfid int input file-identifier
c (can be obtained by calling routine
c opncdf)
c varnam char input the user-supplied variable name.
c (can be obtained by calling routine
c opncdf)
c ndim int input the number of dimensions (ndim<=4)
c misdat real input missing data value for the variable.
c vardim int input the dimensions of the variable.
c is dimensioned at least (ndim).
c varmin real input the location in physical space of the
c origin of each variable.
c is dimensioned at least Min(ndim,3).
c varmax real input the extent of each variable in physical
c space.
c is dimensioned at least Min(ndim,3).
c stag real input the grid staggering for each variable.
c is dimensioned at least Min(ndim,3).
c dat real input data-array dimensioned suffiecently
c large, at least
c vardim(1)* ... vardim(ndim)
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 error detected.
c History:
c Nov. 91 PPM UW Created cr3df, wr3df.
c Jan. 92 CS UW Created putcdf.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
character *(*) varnam
integer vardim(*), ndim, error, cdfid
real misdat, stag(*), varmin(*), varmax(*), dat(*)
c Local variable declarations.
character *(20) dimnam,attnam,dimchk
character *(1) chrid(MAXDIM)
character *(20) dimnams(MAXNCDIM)
integer dimvals(MAXNCDIM)
integer numdims,numvars,numgats,dimulim
integer id,did(MAXDIM),i,k,corner(MAXDIM)
integer ncopts
integer ibeg,iend
data chrid/'x','y','z','t'/
data corner/1,1,1,1/
c Get current value of error options.
call ncgopt (ncopts)
c make sure netCDF-errors do not abort execution
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c Make sure ndim <= MAXDIM.
if (ndim.gt.MAXDIM) then
error = 1
go to 900
endif
c Read existing dimensions-declarations from the file
call ncinq(cdfid,numdims,numvars,numgats,dimulim,error)
if (error.ne.0) numdims=0
if (numdims.gt.0) then
do i=1,numdims
call ncdinq(cdfid,i,dimnams(i),dimvals(i),error)
c print *,dimnams(i),dimvals(i)
enddo
endif
c put file into define mode
call ncredf(cdfid,error)
if (error.ne.0) goto 920
c define the dimension
do k=1,ndim
c define the dimension-name
dimnam(1:3)='dim'
dimnam(4:4)=chrid(k)
dimnam(5:5)='_'
dimnam(6:5+len_trim(varnam))=trim(varnam)
dimnam=dimnam(1:5+len_trim(varnam))
did(k)=-1
if (numdims.gt.0) then
c check if an existing dimension-declaration can be used
c instead of defining a nuw dimension
do i=1,numdims
dimchk=dimnams(i)
if ((vardim(k).eq.dimvals(i)).and.
& (dimnam(1:4).eq.dimchk(1:4))) then
did(k)=i
goto 100
endif
enddo
100 continue
endif
if (did(k).lt.0) then
c define the dimension
did(k)=ncddef(cdfid,dimnam,vardim(k),error)
if (error.ne.0) goto 920
endif
enddo
c define variable
id=ncvdef(cdfid,varnam,NCFLOAT,ndim,did,error)
if (error.ne.0) goto 920
c define attributes
do k=1,min0(ndim,3)
c staggering
attnam(1:1)=chrid(k)
attnam(2:5)='stag'
attnam=attnam(1:5)
call ncapt(cdfid,id,attnam,NCFLOAT,1,stag(k),error)
if (error.gt.0) goto 920
c min postion
attnam(1:1)=chrid(k)
attnam(2:4)='min'
attnam=attnam(1:4)
call ncapt(cdfid,id,attnam,NCFLOAT,1,varmin(k),error)
if (error.gt.0) goto 920
c max position
attnam(1:1)=chrid(k)
attnam(2:4)='max'
attnam=attnam(1:4)
call ncapt(cdfid,id,attnam,NCFLOAT,1,varmax(k),error)
if (error.gt.0) goto 920
enddo
c define missing data value
call ncapt(cdfid,id,'missing_data',NCFLOAT,1,misdat,error)
if (error.gt.0) goto 920
c leave define mode
call ncendf(cdfid,error)
if (error.gt.0) goto 920
c define data
call ncvpt(cdfid,id,corner,vardim,dat,error)
if (error.gt.0) goto 920
c synchronyse output to disk and exit
call ncsnc (cdfid,error)
call ncpopt (ncopts)
return
c Error exits.
900 write (6, *) 'ERROR: When calling putcdf, the number of ',
& 'variable dimensions must be less or equal 4.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'write the data file in subroutine putcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
end
c
c
subroutine getdef (cdfid, varnam, ndim, misdat,
& vardim, varmin, varmax, stag, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to get the dimensions and attributes of
c a variable from an IVE-NetCDF file for use with the IVE plotting
c package. Prior to calling this routine, the file must be opened
c with a call to opncdf.
c Arguments:
c cdfid int input file-identifier
c (can be obtained by calling routine
c opncdf)
c varnam char input the user-supplied variable name.
c (can be obtained by calling routine
c opncdf)
c ndim int output the number of dimensions (ndim<=4)
c misdat real output missing data value for the variable.
c vardim int output the dimensions of the variable.
c Is dimensioned at least (ndim).
c varmin real output the location in physical space of the
c origin of each variable.
c Is dimensioned at least Min(3,ndim).
c varmax real output the extend of each variable in physical
c space.
c Is dimensioned at least Min(3,ndim).
c stag real output the grid staggering for each variable.
c Is dimensioned at least Min(3,ndim).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 the variable is not on the file.
c error =10 other errors.
c History:
c Apr. 93 Christoph Schaer (ETHZ) Created.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
character *(*) varnam
integer vardim(*), ndim, error, cdfid
real misdat, stag(*), varmin(*), varmax(*)
c Local variable declarations.
character *(20) dimnam(MAXNCDIM),attnam,vnam
character *(1) chrid(MAXDIM)
integer id,i,k
integer ndims,nvars,ngatts,recdim,dimsiz(MAXNCDIM)
integer vartyp,nvatts, ncopts
data chrid/'x','y','z','t'/
c Get current value of error options.
call ncgopt (ncopts)
c make sure NetCDF-errors do not abort execution
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c inquire for number of dimensions
call ncinq(cdfid,ndims,nvars,ngatts,recdim,error)
if (error.eq.1) goto 920
c read dimension-table
do i=1,ndims
call ncdinq(cdfid,i,dimnam(i),dimsiz(i),error)
if (error.gt.0) goto 920
enddo
c get id of the variable
id=ncvid(cdfid,varnam,error)
if (error.eq.1) goto 910
c inquire about variable
call ncvinq(cdfid,id,vnam,vartyp,ndim,vardim,nvatts,error)
if (vartyp.ne.NCFLOAT) error=1
if (error.gt.0) goto 920
c Make sure ndim <= MAXDIM.
if (ndim.gt.MAXDIM) then
error = 1
go to 900
endif
c get dimensions from dimension-table
do k=1,ndim
vardim(k)=dimsiz(vardim(k))
enddo
c get attributes
do k=1,min0(3,ndim)
c get min postion
attnam(1:1)=chrid(k)
attnam(2:4)='min'
attnam=attnam(1:4)
call ncagt(cdfid,id,attnam,varmin(k),error)
if (error.gt.0) goto 920
c get max position
attnam(1:1)=chrid(k)
attnam(2:4)='max'
attnam=attnam(1:4)
call ncagt(cdfid,id,attnam,varmax(k),error)
if (error.gt.0) goto 920
c get staggering
attnam(1:1)=chrid(k)
attnam(2:5)='stag'
attnam=attnam(1:5)
call ncagt(cdfid,id,attnam,stag(k),error)
if (error.gt.0) goto 920
enddo
c get missing data value
call ncagt(cdfid,id,'missing_data',misdat,error)
if (error.gt.0) goto 920
c normal exit
call ncpopt (ncopts)
return
c Error exits.
900 write (6, *) '*ERROR*: When calling getcdf, the number of ',
& 'variable dimensions must be less or equal 4.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
910 write (6, *) '*ERROR*: The selected variable could not be found ',
& 'in the file by getcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
920 write (6, *) '*ERROR*: An error occurred while attempting to ',
& 'read the data file in subroutine getcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
end
subroutine getdat(cdfid, varnam, time, level, dat, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to read the data of a variable
c from an IVE-NetCDF file for use with the IVE plotting package.
c Prior to calling this routine, the file must be opened with
c a call to opncdf (for extension) or crecdf (for creation) or
c readcdf (for readonly).
c Arguments:
c cdfid int input file-identifier
c (must be obtained by calling routine
c opncdf,readcdf or crecdf)
c varnam char input the user-supplied variable name (must
c previously be defined with a call to
c putdef)
c time real input the user-supplied time-level of the
c data to be read from the file (the time-
c levels stored in the file can be obtained
c with a call to gettimes).
c level int input the horizontal level(s) to be read
c to the NetCDF file. Suppose that the
c variable is defined as (nx,ny,nz,nt).
c level>0: the call reads the subdomain
c (1:nx,1:ny,level,itimes)
c level=0: the call reads the subdomain
c (1:nx,1:ny,1:nz,itimes)
c Here itimes is the time-index corresponding
c to the value of 'time'.
c dat real output data-array dimensioned sufficiently
c large. The dimensions (nx,ny,nz)
c of the variable must previously be defined
c with a call to putdef. No previous
c definition of the time-dimension is
c required.
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 the variable is not present on
c the file.
c error = 2 the value of 'time' is not
c known.to the file.
c error = 3 inconsistent value of level
c error =10 another error.
c History:
c March 93 Heini Wernli (ETHZ) Created wr2cdf.
c April 93 Bettina Messmer (ETHZ) Created putdat.
c June 93 Christoph Schaer (ETHZ) Created getdat
c Sept. 07 Johannes Jenkner (ETHZ) Integer and double times
c-----------------------------------------------------------------------
include "netcdf.inc"
C Declaration of local variables
character*(*) varnam
character*(20) chars,dimnam
integer cdfid
real dat(*)
real misdat,varmin(3),varmax(3),stag(3)
real time, timeval
integer corner(4),edgeln(4),didtim,vardim(4),ndims
integer error, ierr
integer level,ntime
integer idtime,idvar,iflag
integer i
integer vtyp,dn,nat
integer dims(4)
integer inttime
double precision doubletime
call ncpopt(NCVERBOS)
c access the variable
call getdef (cdfid, trim(varnam), ndims, misdat,
& vardim, varmin, varmax, stag, ierr)
if (ierr.ne.0) then
print *,'*ERROR* in getdef in getdat'
error=1
return
endif
idvar=ncvid(cdfid,trim(varnam),ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncvid in getdat'
error=1
return
endif
C Get times-array
didtim=ncdid(cdfid,'time',ierr)
if (ierr.ne.0) then
print *,'*ERROR* didtim in getdat'
error=10
return
endif
call ncdinq(cdfid,didtim,chars,ntime,ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncdinq in getdat'
error=10
return
endif
idtime=ncvid(cdfid,'time',ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncvid for time in getdat'
error=10
return
endif
c find appropriate time-index
iflag=0
call ncvinq(cdfid,idtime,dimnam,vtyp,dn,dims,natt,ierr)
do i=1,ntime
if (vtyp.eq.5) then
call ncvgt1(cdfid,idtime,i,timeval,ierr)
elseif (vtyp.eq.4) then ! integer version
call ncvgt1(cdfid,idtime,i,inttime,ierr)
timeval=real(inttime)
elseif (vtyp.eq.6) then ! double precision version
call ncvgt1(cdfid,idtime,i,doubletime,ierr)
timeval=real(doubletime)
endif
if (ierr.ne.0) print *,'*ERROR* in ncvgt1 in getdat'
if (time.eq.timeval) iflag=i
enddo
if (iflag.eq.0) then
error=2
print *,'Error: Unknown time in getdat'
return
endif
C Define data volume to be written (index space)
corner(1)=1
corner(2)=1
edgeln(1)=vardim(1)
edgeln(2)=vardim(2)
if (level.eq.0) then
corner(3)=1
edgeln(3)=vardim(3)
else if ((level.le.vardim(3)).and.(level.ge.1)) then
corner(3)=level
edgeln(3)=1
else
error=3
return
endif
corner(4)=iflag
edgeln(4)=1
C Read data from NetCDF file
c print *,'getdat vor Aufruf ncvgt'
c print *,'cdfid ',cdfid
c print *,'idvar ',idvar
c print *,'corner ',corner
c print *,'edgeln ',edgeln
call ncvgt(cdfid,idvar,corner,edgeln,dat,error)
if (error.ne.0) then
print *, '*ERROR* in ncvgt in getdat'
error=10
endif
end
subroutine putdat(cdfid, varnam, time, level, dat, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to write the data of a variable
c to an IVE-NetCDF file for use with the IVE plotting package.
c Prior to calling this routine, the file must be opened with
c a call to opncdf (for extension) or crecdf (for creation), the
c variable must be defined with a call to putdef.
c Arguments:
c cdfid int input file-identifier
c (must be obtained by calling routine
c opncdf or crecdf)
c varnam char input the user-supplied variable name (must
c previously be defined with a call to
c putdef)
c time real input the user-supplied time-level of the
c data to be written to the file (the time-
c levels stored in the file can be obtained
c with a call to gettimes). If 'time' is not
c yet known to the file, a knew time-level is
c allocated and appended to the times-array.
c level int input the horizontal level(s) to be written
c to the NetCDF file. Suppose that the
c variable is defined as (nx,ny,nz,nt).
c level>0: the call writes the subdomain
c (1:nx,1:ny,level,itimes)
c level=0: the call writes the subdomain
c (1:nx,1:ny,1:nz,itimes)
c Here itimes is the time-index corresponding
c to the value of 'time'.
c dat real output data-array dimensioned sufficiently
c large. The dimensions (nx,ny,nz)
c of the variable must previously be defined
c with a call to putdef. No previous
c definition of the time-dimension is
c required.
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 the variable is not present on
c the file.
c error = 2 the value of 'time' is new, but
c appending it would yield a non
c ascending times-array.
c error = 3 inconsistent value of level
c error =10 another error.
c History:
c March 93 Heini Wernli (ETHZ) Created wr2cdf.
c April 93 Bettina Messmer (ETHZ) Created putdat.
c-----------------------------------------------------------------------
include "netcdf.inc"
C Declaration of local variables
character*(*) varnam
character*(20) chars
integer cdfid
real dat(*)
real misdat,varmin(3),varmax(3),stag(3)
real time, timeval
data stag/0.,0.,0./
integer corner(4),edgeln(4),did(4),vardim(4),ndims
integer error, ierr
integer level,ntime
integer idtime,idvar,iflag
integer i
call ncpopt(NCVERBOS)
c get definitions of data
call getdef (cdfid, trim(varnam), ndims, misdat,
& vardim, varmin, varmax, stag, ierr)
if (ierr.ne.0) print *,'*ERROR* in getdef in putdat'
c get id of variable
idvar=ncvid(cdfid,trim(varnam),ierr)
if (ierr.ne.0) print *,'*ERROR* in ncvid in putdat'
c get times-array
did(4)=ncdid(cdfid,'time',ierr)
if (ierr.ne.0) print *,'*ERROR* did(4) in putdat'
call ncdinq(cdfid,did(4),chars,ntime,ierr)
if (ierr.ne.0) print *,'*ERROR* in ncdinq in putdat'
idtime=ncvid(cdfid,'time',ierr)
if (ierr.ne.0) print *,'*ERROR* in ncvid in putdat'
C Check if a new time step is starting
iflag=0
do i=1,ntime
call ncvgt1(cdfid,idtime,i,timeval,ierr)
if (ierr.ne.0) print *,'*ERROR* in ncvgt1 in putdat'
if (time.eq.timeval) iflag=i
enddo
if (iflag.eq.0) then ! new time step
ntime=ntime+1
iflag=ntime
idtime=ncvid(cdfid,'time',ierr)
if (ierr.ne.0) print *, '*ERROR* in ncvid in putdat'
call ncvpt1(cdfid,idtime,ntime,time,ierr)
if (ierr.ne.0) print *, '*ERROR* in ncvpt1 in putdat'
endif
C Define data volume to write on the NetCDF file in index space
corner(1)=1 ! starting corner of data volume
corner(2)=1
edgeln(1)=vardim(1) ! edge lengthes of data volume
edgeln(2)=vardim(2)
if (level.eq.0) then
corner(3)=1
edgeln(3)=vardim(3)
else
corner(3)=level
edgeln(3)=1
endif
corner(4)=iflag
edgeln(4)=1
C Put data on NetCDF file
c print *,'vor Aufruf ncvpt d.h. Daten schreiben in putdat '
c print *,'cdfid ',cdfid
c print *,'idvar ',idvar
c print *,'corner ',corner
c print *,'edgeln ',edgeln
call ncvpt(cdfid,idvar,corner,edgeln,dat,error)
if (error.ne.0) then
print *, '*ERROR* in ncvpt in putdat - Put data on NetCDF file'
endif
C Synchronize output to disk and close the files
call ncsnc(cdfid,ierr)
if (ierr.ne.0) print *, '*ERROR* in ncsnc in putdat'
end
subroutine putdef (cdfid, varnam, ndim, misdat,
& vardim, varmin, varmax, stag, error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to define the dimensions and the
c attributes of a variable on an IVE-NetCDF file for use with the
c IVE plotting package. Prior to calling this routine, the file must
c be opened with a call to opncdf (extend an existing file) or
c crecdf (create a new file).
c Arguments:
c cdfid int input file-identifier
c (can be obtained by calling routine
c opncdf)
c varnam char input the user-supplied variable name.
c ndim int input the number of dimensions (ndim<=4).
c Upon ndim=4, the fourth dimension of the
c variable is specified as 'unlimited'
c on the file (time-dimension). It can
c later be extended to arbitrary length.
c misdat real input missing data value for the variable.
c vardim int input the dimensions of the variable.
c Is dimensioned at least Min(3,ndim).
c varmin real input the location in physical space of the
c origin of each variable.
c Is dimensioned at least Min(3,ndim).
c varmax real input the extent of each variable in physical
c space.
c Is dimensioned at least Min(ndim).
c stag real input the grid staggering for each variable.
c Is dimensioned at least Min(3,ndim).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error =10 other errors detected.
c History:
c Apr. 93 Christoph Schaer (ETHZ) Created.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
integer MAXDIM
parameter (MAXDIM=4)
character *(*) varnam
integer vardim(*), ndim, error, cdfid
real misdat, stag(*), varmin(*), varmax(*)
c Local variable declarations.
character *(20) dimnam,attnam,dimchk
character *(1) chrid(MAXDIM)
character *(20) dimnams(MAXNCDIM)
integer dimvals(MAXNCDIM)
integer numdims,numvars,numgats,dimulim
integer id,did(MAXDIM),idtime,i,k,ierr
integer ncopts
integer ibeg,iend
data chrid/'x','y','z','t'/
c Get current value of error options.
call ncgopt (ncopts)
c make sure NetCDF-errors do not abort execution
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c Make sure ndim <= MAXDIM.
if (ndim.gt.MAXDIM) then
error = 10
go to 900
endif
c Read existing dimensions-declarations from the file
call ncinq(cdfid,numdims,numvars,numgats,dimulim,error)
if (numdims.gt.0) then
do i=1,numdims
call ncdinq(cdfid,i,dimnams(i),dimvals(i),error)
c print *,dimnams(i),dimvals(i)
enddo
endif
c put file into define mode
call ncredf(cdfid,error)
if (error.ne.0) goto 920
c define spatial dimensions
do k=1,min0(3,ndim)
c define the default dimension-name
dimnam(1:3)='dim'
dimnam(4:4)=chrid(k)
dimnam(5:5)='_'
dimnam(6:5+len_trim(varnam))=trim(varnam)
dimnam=dimnam(1:5+len_trim(varnam))
did(k)=-1
if (numdims.gt.0) then
c check if an existing dimension-declaration can be used
c instead of defining a new dimension
do i=1,numdims
dimchk=dimnams(i)
if ((vardim(k).eq.dimvals(i)).and.
& (dimnam(1:4).eq.dimchk(1:4))) then
did(k)=i
goto 100
endif
enddo
100 continue
endif
if (did(k).lt.0) then
c define the dimension
did(k)=ncddef(cdfid,dimnam,vardim(k),error)
if (error.ne.0) goto 920
endif
enddo
c define the times-array
if (ndim.eq.4) then
c define dimension and variable 'time'
if (numdims.ge.4) then
did(4)=ncdid(cdfid,'time',ierr)
idtime=ncvid(cdfid,'time',ierr)
else
c this dimension must first be defined
did(4) = ncddef (cdfid,'time',NCUNLIM,ierr)
idtime = ncvdef (cdfid,'time',NCFLOAT,1,did(4),ierr)
endif
endif
c define variable
id=ncvdef(cdfid,varnam,NCFLOAT,ndim,did,error)
if (error.ne.0) goto 920
c define attributes
do k=1,min0(ndim,3)
c min postion
attnam(1:1)=chrid(k)
attnam(2:4)='min'
attnam=attnam(1:4)
call ncapt(cdfid,id,attnam,NCFLOAT,1,varmin(k),error)
if (error.gt.0) goto 920
c max position
attnam(1:1)=chrid(k)
attnam(2:4)='max'
attnam=attnam(1:4)
call ncapt(cdfid,id,attnam,NCFLOAT,1,varmax(k),error)
if (error.gt.0) goto 920
c staggering
attnam(1:1)=chrid(k)
attnam(2:5)='stag'
attnam=attnam(1:5)
call ncapt(cdfid,id,attnam,NCFLOAT,1,stag(k),error)
if (error.gt.0) goto 920
enddo
c define missing data value
call ncapt(cdfid,id,'missing_data',NCFLOAT,1,misdat,error)
if (error.gt.0) goto 920
c leave define mode
call ncendf(cdfid,error)
if (error.gt.0) goto 920
c synchronyse output to disk and exit
call ncsnc (cdfid,error)
call ncpopt (ncopts)
return
c Error exits.
900 write (6, *) '*ERROR*: When calling putcdf, the number of ',
& 'variable dimensions must be less or equal 4.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
920 write (6, *) '*ERROR*: An error occurred while attempting to ',
& 'write the data file in subroutine putcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
end
subroutine puttimes(cdfid,times,ntimes,ierr)
C------------------------------------------------------------------------
C Purpose:
C Redefine all times on the specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C times real input array contains all time values on the file,
C dimensioned at least times(ntimes)
C ntimes int input number of times on the file
C error int output errorflag
C History:
C Heini Wernli, ETHZ
C Christoph Schaer, ETHZ
C Johannes Jenkner, ETHZ (adjustment for integer and double times)
C Note:
C This preliminary version does not define the times-array, but only
C overwrites or extends an existing times-array.
C------------------------------------------------------------------------
integer ierr,i
real times(*)
integer didtim,ntimes
integer cdfid,idtime,nfiltim
integer ncdid,ncvid
integer vtyp,dn,nat
integer dims(4)
idtime=ncvid(cdfid,'time',ierr) ! inquire id for time array
if (ierr.ne.0) return
didtim=ncdid(cdfid,'time',ierr) ! inquire id for time dimension
if (ierr.ne.0) return
call ncdinq(cdfid,didtim,'time',nfiltim,ierr) ! inquire # of times
if (ierr.ne.0) return
call ncvinq(cdfid,idtime,dimnam,vtyp,dn,dims,natt,ierr)
if (nfiltim.lt.ntimes) then
print *,'Warning: puttimes is extending times-array'
else if (nfiltim.gt.ntimes) then
print *,'Warning: puttimes does not cover range of times-array'
endif
if (vtyp.eq.5) then
do i=1,ntimes
call ncvpt1(cdfid,idtime,i,times(i),ierr)
if (ierr.ne.0) return
enddo
elseif (vtyp.eq.4) then ! integer version
do i=1,ntimes
call ncvpt1(cdfid,idtime,i,int(times(i)),ierr)
if (ierr.ne.0) return
enddo
elseif (vtyp.eq.6) then ! double precision version
do i=1,ntimes
call ncvgt1(cdfid,idtime,i,dble(times(i)),ierr)
if (ierr.ne.0) return
enddo
else
return
endif
end
subroutine gettimes(cdfid,times,ntimes,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get all times on the specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C times real output array contains all time values on the file,
C dimensioned at least times(ntimes)
C ntimes int output number of times on the file
C error int output errorflag
C History:
C Heini Wernli, ETHZ
C Johannes Jenkner, ETHZ (adjustment for integer and double times)
C------------------------------------------------------------------------
include "netcdf.inc"
integer ierr,i
real times(*)
integer didtim,ntimes
integer cdfid,idtime
integer ncopts
character*(20) dimnam
integer vtyp,dn,nat
integer dims(4)
integer,dimension(:),allocatable :: inttimes
double precision,dimension(:),allocatable :: doubletimes
c Get current value of error options, and make sure netCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt(NCVERBOS)
didtim=ncdid(cdfid,'time',ierr) ! inquire id for time dimension
if (ierr.ne.0) goto 900
idtime=ncvid(cdfid,'time',ierr) ! inquire id for time array
if (ierr.ne.0) goto 900
call ncdinq(cdfid,didtim,dimnam,ntimes,ierr) ! inquire # of times
if (ierr.ne.0) goto 900
call ncvinq(cdfid,idtime,dimnam,vtyp,dn,dims,natt,ierr)
if (vtyp.eq.5) then
do i=1,ntimes
call ncvgt1(cdfid,idtime,i,times(i),ierr) ! get times
if (ierr.ne.0) goto 900
enddo
elseif (vtyp.eq.4) then ! integer version
allocate(inttimes(ntimes))
do i=1,ntimes
call ncvgt1(cdfid,idtime,i,inttimes(i),ierr) ! get times
if (ierr.ne.0) goto 900
enddo
times(1:ntimes)=real(inttimes(1:ntimes))
elseif (vtyp.eq.6) then ! double precision version
allocate(doubletimes(ntimes))
do i=1,ntimes
call ncvgt1(cdfid,idtime,i,doubletimes(i),ierr) ! get times
if (ierr.ne.0) goto 900
enddo
times(1:ntimes)=real(doubletimes(1:ntimes))
else
goto 900
endif
c normal exit
call ncpopt (ncopts)
return
c error exit
900 ntimes=1
times(1)=0.
call ncpopt (ncopts)
end
subroutine cpp_crecdf(filnam,filnam_len,cdfid,phymin,phymax,ndim,
& cfn,cfn_len,error)
C------------------------------------------------------------------------
C Purpose:
C allows to call crecdf from c++
C Arguments:
C see crecdf
C additionally: fname_len and cfn_len, the length of the
C strings
C
C
C History:
C 981221 Mark A. Liniger ETHZ
C
C Note:
C
C
C------------------------------------------------------------------------
integer filnam_len,ndim,cfn_len,error,cdfid
character *(*) filnam,cfn
real phymin(*),phymax(*)
call crecdf (filnam(1:filnam_len),cdfid,phymin,phymax,ndim,
& cfn(1:cfn_len),error)
end
subroutine cpp_putdef(cdfid,varnam,varnam_len,ndim,misdat,
& vardim,varmin,varmax,stag,error)
C------------------------------------------------------------------------
C Purpose:
C allows to call putdef from c++
C Arguments:
C see crecdf
C additionally: varnam_len, the length of the
C strings
C
C
C History:
C 981221 Mark A. Liniger ETHZ
C
C Note:
C
C
C------------------------------------------------------------------------
integer varnam_len,ndim,error,vardim(*),cdfid
character *(*) varnam
real misdat,stag(*),varmin(*),varmax(*)
call putdef (cdfid, varnam(1:varnam_len), ndim, misdat,
& vardim, varmin, varmax, stag, error)
end
subroutine cpp_putdat(cdfid, varnam,varnam_len,
& time, level, dat, error)
C------------------------------------------------------------------------
C Purpose:
C allows to call putdef from c++
C Arguments:
C see crecdf
C additionally: varnam_len, the length of the
C strings
C
C
C History:
C 981221 Mark A. Liniger ETHZ
C
C Note:
C
C
C------------------------------------------------------------------------
integer varnam_len,cdfid,error,level
character *(*) varnam
real dat(*)
real time
call putdat(cdfid, varnam(1:varnam_len), time, level, dat, error)
end

/tags/1.0/lib/libcdfplus.f
0,0 → 1,1568
subroutine wricst(cstnam,datar,aklev,bklev,aklay,bklay,stdate)
C------------------------------------------------------------------------
C Creates the constants file for NetCDF files containing ECMWF
C data. The constants file is compatible with the one created
C for EM data (with subroutine writecst).
C
C Input parameters:
C
C cstnam name of constants file
C datar array contains all required parameters to write file
C datar(1): number of points along x
C datar(2): number of points along y
C datar(3): maximum latitude of data region (ymax)
C datar(4): minimum longitude of data region (xmin)
C datar(5): minimum latitude of data region (ymin)
C datar(6): maximum longitude of data region (xmax)
C datar(7): grid increment along x
C datar(8): grid increment along y
C datar(9): number of levels
C datar(10): data type (forecast or analysis)
C datar(11): data version
C datar(12): constants file version
C datar(13): longitude of pole of coordinate system
C datar(14): latitude of pole of coordinate system
C aklev array contains the aklev values
C bklev array contains the bklev values
C aklay array contains the aklay values
C bklay array contains the bklay values
C stdate array contains date (year,month,day,time,step) of first
C field on file (start-date), dimensionised as stdate(5)
C------------------------------------------------------------------------
include "netcdf.inc"
integer nchar,maxlev
parameter (nchar=20,maxlev=32)
real aklev(maxlev),bklev(maxlev)
real aklay(maxlev),bklay(maxlev)
real pollat,latmin,latmax
integer datar(14)
integer stdate(5)
character*80 cstnam
C declarations for constants-variables
integer nz
integer dattyp, datver, cstver
C further declarations
integer ierr ! error flag
integer cdfid ! NetCDF id
integer xid,yid,zid ! dimension ids
integer pollonid, pollatid, ! variable ids
> aklevid, bklevid, aklayid, bklayid,
> lonminid, lonmaxid, latminid, latmaxid,
> dellonid, dellatid,
> startyid, startmid, startdid, starthid, startsid,
> dattypid, datverid, cstverid
nz=datar(9) ! number of levels
C Set data-type and -version, version of cst-file-format
dattyp=datar(10)
datver=datar(11)
cstver=datar(12)
C Initially set error to false
ierr=0
C Create constants file
cdfid=nccre(trim(cstnam),NCCLOB,ierr)
C Define the dimensions
xid = ncddef (cdfid,'nx',datar(1),ierr)
yid = ncddef (cdfid,'ny',datar(2),ierr)
zid = ncddef (cdfid,'nz',datar(9),ierr)
C Define integer constants
pollonid = ncvdef(cdfid,'pollon', NCFLOAT,0,0,ierr)
pollatid = ncvdef(cdfid,'pollat', NCFLOAT,0,0,ierr)
aklevid = ncvdef (cdfid, 'aklev', NCFLOAT, 1, zid, ierr)
bklevid = ncvdef (cdfid, 'bklev', NCFLOAT, 1, zid, ierr)
aklayid = ncvdef (cdfid, 'aklay', NCFLOAT, 1, zid, ierr)
bklayid = ncvdef (cdfid, 'bklay', NCFLOAT, 1, zid, ierr)
lonminid = ncvdef (cdfid, 'lonmin', NCFLOAT, 0, 0, ierr)
lonmaxid = ncvdef (cdfid, 'lonmax', NCFLOAT, 0, 0, ierr)
latminid = ncvdef (cdfid, 'latmin', NCFLOAT, 0, 0, ierr)
latmaxid = ncvdef (cdfid, 'latmax', NCFLOAT, 0, 0, ierr)
dellonid = ncvdef (cdfid, 'dellon', NCFLOAT, 0, 0, ierr)
dellatid = ncvdef (cdfid, 'dellat', NCFLOAT, 0, 0, ierr)
startyid = ncvdef (cdfid, 'starty', NCLONG, 0, 0, ierr)
startmid = ncvdef (cdfid, 'startm', NCLONG, 0, 0, ierr)
startdid = ncvdef (cdfid, 'startd', NCLONG, 0, 0, ierr)
starthid = ncvdef (cdfid, 'starth', NCLONG, 0, 0, ierr)
startsid = ncvdef (cdfid, 'starts', NCLONG, 0, 0, ierr)
dattypid = ncvdef (cdfid, 'dattyp', NCLONG, 0, 0, ierr)
datverid = ncvdef (cdfid, 'datver', NCLONG, 0, 0, ierr)
cstverid = ncvdef (cdfid, 'cstver', NCLONG, 0, 0, ierr)
C Leave define mode
call ncendf(cdfid,ierr)
C Store levels
call ncvpt(cdfid, aklevid, 1, nz, aklev, ierr)
call ncvpt(cdfid, bklevid, 1, nz, bklev, ierr)
call ncvpt(cdfid, aklayid, 1, nz, aklay, ierr)
call ncvpt(cdfid, bklayid, 1, nz, bklay, ierr)
C Store position of pole (trivial for ECMWF data)
call ncvpt1(cdfid, pollonid, 1, real(datar(13))/1000., ierr)
if (datar(14).gt.0) then
pollat=min(real(datar(14))/1000.,90.)
else
pollat=max(real(datar(14))/1000.,-90.)
endif
call ncvpt1(cdfid, pollatid, 1, pollat, ierr)
C Store horizontal data borders and grid increments
call ncvpt1(cdfid, lonminid, 1, real(datar(4))/1000., ierr)
call ncvpt1(cdfid, lonmaxid, 1, real(datar(6))/1000., ierr)
latmin=max(real(datar(5))/1000.,-90.)
latmax=min(real(datar(3))/1000.,90.)
call ncvpt1(cdfid, latminid, 1, latmin, ierr)
call ncvpt1(cdfid, latmaxid, 1, latmax, ierr)
call ncvpt1(cdfid, dellonid, 1, real(datar(7))/1000., ierr)
call ncvpt1(cdfid, dellatid, 1, real(datar(8))/1000., ierr)
C Store date of first field on file (start-date)
call ncvpt1(cdfid, startyid, 1, stdate(1), ierr)
call ncvpt1(cdfid, startmid, 1, stdate(2), ierr)
call ncvpt1(cdfid, startdid, 1, stdate(3), ierr)
call ncvpt1(cdfid, starthid, 1, stdate(4), ierr)
call ncvpt1(cdfid, startsid, 1, stdate(5), ierr)
C Store datatype and version
call ncvpt1(cdfid, dattypid, 1, dattyp, ierr)
call ncvpt1(cdfid, datverid, 1, datver, ierr)
C Store version of the constants file format
call ncvpt1(cdfid, cstverid, 1, cstver, ierr)
C Store strings
call ncclos(cdfid,ierr)
return
end
subroutine writelmcst(cdfid,nx,ny,nz,pollon,pollat,lonmin,
&lonmax,latmin,latmax,dellon,dellat,dattyp,datver,cstver,
&psref,tstar,tbeta,pintf,p0top,idate)
c ------------------------------------------------------------------
implicit none
integer cdfid
c deklarationen der constants-variablen
real pollon,pollat
real lonmin,lonmax,latmin,latmax,dellon,dellat
integer idate(5)
integer nx,ny,nz
integer dattyp, datver, cstver
real psref, tstar, tbeta, pintf, p0top
include 'netcdf.inc'
* netcdf declaration
integer iret, k
* dimension ids
integer nxdim, nydim, nzdim
* variable ids
integer startyid, startmid, startdid, starthid
* variable shapes, corners and edge lengths
integer dims(1), corner(1), edges(1)
* enter define mode
call ncredf(cdfid, iret)
startyid = ncvdef (cdfid, 'starty', NCLONG, 0, 0, iret)
startmid = ncvdef (cdfid, 'startm', NCLONG, 0, 0, iret)
startdid = ncvdef (cdfid, 'startd', NCLONG, 0, 0, iret)
starthid = ncvdef (cdfid, 'starth', NCLONG, 0, 0, iret)
* store the rest as global attributes
* store nx,ny,nz
call ncapt(cdfid,NCGLOBAL,'nx',NCLONG,1,nx,iret)
call ncapt(cdfid,NCGLOBAL,'ny',NCLONG,1,ny,iret)
call ncapt(cdfid,NCGLOBAL,'nz',NCLONG,1,nz,iret)
* store pollon, pollat
call ncapt(cdfid,NCGLOBAL,'pollon',NCFLOAT,1,pollon,iret)
call ncapt(cdfid,NCGLOBAL,'pollat',NCFLOAT,1,pollat,iret)
* store lonmin, etc
call ncapt(cdfid,NCGLOBAL,'lonmin',NCFLOAT,1,lonmin,iret)
call ncapt(cdfid,NCGLOBAL,'lonmax',NCFLOAT,1,lonmax,iret)
call ncapt(cdfid,NCGLOBAL,'latmin',NCFLOAT,1,latmin,iret)
call ncapt(cdfid,NCGLOBAL,'latmax',NCFLOAT,1,latmax,iret)
call ncapt(cdfid,NCGLOBAL,'dellon',NCFLOAT,1,dellon,iret)
call ncapt(cdfid,NCGLOBAL,'dellat',NCFLOAT,1,dellat,iret)
* store data type and version
call ncapt(cdfid,NCGLOBAL,'dattyp',NCLONG,1,dattyp,iret)
call ncapt(cdfid,NCGLOBAL,'datver',NCLONG,1,datver,iret)
call ncapt(cdfid,NCGLOBAL,'cstver',NCLONG,1,cstver,iret)
* store information of lm model vertical grid
call ncapt(cdfid,NCGLOBAL,'psref',NCFLOAT,1,psref,iret)
call ncapt(cdfid,NCGLOBAL,'tstar',NCFLOAT,1,tstar,iret)
call ncapt(cdfid,NCGLOBAL,'tbeta',NCFLOAT,1,tbeta,iret)
call ncapt(cdfid,NCGLOBAL,'pintf',NCFLOAT,1,pintf,iret)
call ncapt(cdfid,NCGLOBAL,'p0top',NCFLOAT,1,p0top,iret)
* leave define mode
call ncendf(cdfid, iret)
* store starty, etc
corner(1) = 1
edges(1) = 1
call ncvpt(cdfid, startyid, corner, edges, idate(1), iret)
call ncvpt(cdfid, startmid, corner, edges, idate(2), iret)
call ncvpt(cdfid, startdid, corner, edges, idate(3), iret)
call ncvpt(cdfid, starthid, corner, edges, idate(4), iret)
end
subroutine globcst(cdfnam,datar,aklev,bklev,aklay,bklay,stdate)
C------------------------------------------------------------------------
C+
C NAME:
C subroutine globcst
C
C PURPOSE:
C instead of writing a constants-file (*_cst), the information
C is added to the netCDF file as global variables
C the data format is compatible with the one requested by
C the IVE ETH/MIT version, contact author about details
C
C CATEGORY:
C model,netCDF
C
C CALLING SEQUENCE:
C subroutine globcst(cdfnam,datar,aklev,bklev,aklay,bklay,stdate)
C
C INPUTS:
C cdfnam name of netCDF file
C The file needs to exist, otherwise an ERROR occurs,
C i.e. nothing is done
C datar array contains all required parameters to write file
C datar(1): number of points along x
C datar(2): number of points along y
C datar(3): maximum latitude of data region (ymax)
C datar(4): minimum longitude of data region (xmin)
C datar(5): minimum latitude of data region (ymin)
C datar(6): maximum longitude of data region (xmax)
C datar(7): grid increment along x
C datar(8): grid increment along y
C datar(9): number of levels
C datar(10): data type (forecast or analysis)
C datar(11): data version
C datar(12): constants file version
C datar(13): longitude of pole of coordinate system
C datar(14): latitude of pole of coordinate system
C aklev array contains the aklev values
C bklev array contains the bklev values
C aklay array contains the aklay values
C bklay array contains the bklay values
C stdate array contains date (year,month,day,time,step) of first
C field on file (start-date), dimensionised as stdate(5)
C list the griblist-ASCII-file
C varno the GRIB code number
C
C OUTPUTS:
C Adds cdf-information to EXISTING netCDF-file
C
C MODIFICATION HISTORY:
C
C June 93 Christoph Schaer (ETHZ) created
C Nov 93 Heini Wernli (ETHZ) wricst
C Nov 98 David N. Bresch (MIT) wricst to globcst
C-
C Sun include statement.
include "netcdf.inc"
integer nchar,maxlev
parameter (nchar=20,maxlev=32)
real aklev(maxlev),bklev(maxlev)
real aklay(maxlev),bklay(maxlev)
integer datar(14)
integer stdate(5)
character*80 cdfnam
C declarations for constants-variables
integer nz
integer dattyp, datver, cstver
C further declarations
integer ierr ! error flag
integer cdfid ! NetCDF id
integer xid,yid,zid ! dimension ids
integer pollonid, pollatid, ! variable ids
> aklevid, bklevid, aklayid, bklayid,
> lonminid, lonmaxid, latminid, latmaxid,
> dellonid, dellatid,
> startyid, startmid, startdid, starthid, startsid,
> dattypid, datverid, cstverid
nz=datar(9) ! number of levels
C Set data-type and -version, version of cst-file-format
dattyp=datar(10)
datver=datar(11)
cstver=datar(12)
C Initially set error to false
ierr=0
C open the netCDF-file:
call cdfwopn(cdfnam,cdfid,ierr)
if (ierr.ne.0) then
print*,'ERROR opening netCDF-file ',cdfnam
return
endif
C Put file into define mode
call ncredf(cdfid,ierr)
if (ierr.ne.0) then
print*,'ERROR switching to netCDF redefine mode'
return
endif
C Define the dimensions
xid = ncddef (cdfid,'nx',datar(1),ierr)
yid = ncddef (cdfid,'ny',datar(2),ierr)
zid = ncddef (cdfid,'nz',datar(9),ierr)
C Define integer constants
pollonid = ncvdef(cdfid,'pollon', NCFLOAT,0,0,ierr)
pollatid = ncvdef(cdfid,'pollat', NCFLOAT,0,0,ierr)
aklevid = ncvdef (cdfid, 'aklev', NCFLOAT, 1, zid, ierr)
bklevid = ncvdef (cdfid, 'bklev', NCFLOAT, 1, zid, ierr)
aklayid = ncvdef (cdfid, 'aklay', NCFLOAT, 1, zid, ierr)
bklayid = ncvdef (cdfid, 'bklay', NCFLOAT, 1, zid, ierr)
lonminid = ncvdef (cdfid, 'lonmin', NCFLOAT, 0, 0, ierr)
lonmaxid = ncvdef (cdfid, 'lonmax', NCFLOAT, 0, 0, ierr)
latminid = ncvdef (cdfid, 'latmin', NCFLOAT, 0, 0, ierr)
latmaxid = ncvdef (cdfid, 'latmax', NCFLOAT, 0, 0, ierr)
dellonid = ncvdef (cdfid, 'dellon', NCFLOAT, 0, 0, ierr)
dellatid = ncvdef (cdfid, 'dellat', NCFLOAT, 0, 0, ierr)
startyid = ncvdef (cdfid, 'starty', NCLONG, 0, 0, ierr)
startmid = ncvdef (cdfid, 'startm', NCLONG, 0, 0, ierr)
startdid = ncvdef (cdfid, 'startd', NCLONG, 0, 0, ierr)
starthid = ncvdef (cdfid, 'starth', NCLONG, 0, 0, ierr)
startsid = ncvdef (cdfid, 'starts', NCLONG, 0, 0, ierr)
dattypid = ncvdef (cdfid, 'dattyp', NCLONG, 0, 0, ierr)
datverid = ncvdef (cdfid, 'datver', NCLONG, 0, 0, ierr)
cstverid = ncvdef (cdfid, 'cstver', NCLONG, 0, 0, ierr)
C Leave define mode
call ncendf(cdfid,ierr)
if (ierr.ne.0) then
print*,'ERROR exiting define mode'
return
endif
C Store levels
call ncvpt(cdfid, aklevid, 1, nz, aklev, ierr)
call ncvpt(cdfid, bklevid, 1, nz, bklev, ierr)
call ncvpt(cdfid, aklayid, 1, nz, aklay, ierr)
call ncvpt(cdfid, bklayid, 1, nz, bklay, ierr)
C Store position of pole (trivial for ECMWF data)
call ncvpt1(cdfid, pollonid, 1, real(datar(13))/1000., ierr)
call ncvpt1(cdfid, pollatid, 1, real(datar(14))/1000., ierr)
C Store horizontal data borders and grid increments
call ncvpt1(cdfid, lonminid, 1, real(datar(4))/1000., ierr)
call ncvpt1(cdfid, lonmaxid, 1, real(datar(6))/1000., ierr)
call ncvpt1(cdfid, latminid, 1, real(datar(5))/1000., ierr)
call ncvpt1(cdfid, latmaxid, 1, real(datar(3))/1000., ierr)
call ncvpt1(cdfid, dellonid, 1, real(datar(7))/1000., ierr)
call ncvpt1(cdfid, dellatid, 1, real(datar(8))/1000., ierr)
C Store date of first field on file (start-date)
call ncvpt1(cdfid, startyid, 1, stdate(1), ierr)
call ncvpt1(cdfid, startmid, 1, stdate(2), ierr)
call ncvpt1(cdfid, startdid, 1, stdate(3), ierr)
call ncvpt1(cdfid, starthid, 1, stdate(4), ierr)
call ncvpt1(cdfid, startsid, 1, stdate(5), ierr)
C Store datatype and version
call ncvpt1(cdfid, dattypid, 1, dattyp, ierr)
call ncvpt1(cdfid, datverid, 1, datver, ierr)
C Store version of the constants file format
call ncvpt1(cdfid, cstverid, 1, cstver, ierr)
if (ierr.ne.0) then
print*,'ERROR adding cst-date as global variables'
return
endif
C Store strings
call ncclos(cdfid,ierr)
if (ierr.ne.0) then
print*,'ERROR closing netCDF file'
endif
return
end
subroutine getsdat(cdfid,varnam,time,ix,iy,iz,sx,sy,sz,dat,error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to read the data within a selected
c domain of a variable from an IVE-NetCDF file.
c Prior to calling this routine, the file must be opened with
c a call to opncdf (for extension) or crecdf (for creation) or
c readcdf (for readonly).
c Arguments:
c cdfid int input file-identifier
c (must be obtained by calling routine
c opncdf,readcdf or crecdf)
c varnam char input the user-supplied variable name
c time real input the user-supplied time-level of the
c data to be read from the file (the time-
c levels stored in the file can be obtained
c with a call to gettimes).
c ix/y/z int input indices of lower left corner of selected
c data volume.
c sx/y/z int input size of selected data volume
c dat real output data-array with dimensions (sx,sy,sz).
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 the variable is not present on
c the file.
c error = 2 the value of 'time' is not
c known.to the file.
c error = 6,7,8 data volume too large
c error =10 another error.
c History:
c June 93 Christoph Schaer (ETHZ) Created getdat
c Nov 93 Heini Wernli (ETHZ) Created getsdat
c-----------------------------------------------------------------------
include "netcdf.inc"
C Declaration of local variables
character*(*) varnam
character*(20) chars
integer cdfid
integer ix,iy,iz,sx,sy,sz
real dat(sx,sy,sz)
real misdat,varmin(3),varmax(3),stag(3)
real time, timeval
integer corner(4),edgeln(4),didtim,vardim(4),ndims
integer error, ierr
integer ntime
integer idtime,idvar,iflag
integer i
call ncpopt(NCVERBOS)
c access the variable
call getdef (cdfid, trim(varnam), ndims, misdat,
& vardim, varmin, varmax, stag, ierr)
if (ierr.ne.0) then
print *,'*ERROR* in getdef in getdat'
error=1
return
endif
idvar=ncvid(cdfid,trim(varnam),ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncvid in getsdat'
error=1
return
endif
C Get times-array
didtim=ncdid(cdfid,'time',ierr)
if (ierr.ne.0) then
print *,'*ERROR* didtim in getsdat'
error=10
return
endif
call ncdinq(cdfid,didtim,chars,ntime,ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncdinq in getsdat'
error=10
return
endif
idtime=ncvid(cdfid,'time',ierr)
if (ierr.ne.0) then
print *,'*ERROR* in ncvid for time in getsdat'
error=10
return
endif
c find appropriate time-index
iflag=0
do i=1,ntime
call ncvgt1(cdfid,idtime,i,timeval,ierr)
if (ierr.ne.0) print *,'*ERROR* in ncvgt1 in getsdat'
if (time.eq.timeval) iflag=i
enddo
if (iflag.eq.0) then
error=2
print *,'Error: Unknown time in getsdat'
print *,time,timeval
return
endif
C Define data volume to be written (index space)
corner(1)=ix
corner(2)=iy
corner(3)=iz
corner(4)=iflag
edgeln(1)=sx
edgeln(2)=sy
edgeln(3)=sz
edgeln(4)=1
C Check if data volume is within data domain
if (ix+sx-1.gt.vardim(1)) then
error=7
print *,'Error: data volume too large in x-direction'
print *,ix,sx,vardim(1)
return
endif
if (iy+sy-1.gt.vardim(2)) then
error=8
print *,'Error: data volume too large in y-direction'
return
endif
if (iz+sz-1.gt.vardim(3)) then
error=9
print *,'Error: data volume too large in z-direction'
return
endif
C Read data from NetCDF file
call ncvgt(cdfid,idvar,corner,edgeln,dat,error)
if (error.ne.0) then
print *, 'corner ',corner(1),corner(2),corner(3)
print *, 'edgeln ',edgeln(1),edgeln(2),edgeln(3)
print *, '*ERROR* in ncvgt in getsdat'
error=10
endif
end
subroutine getlevs(cstid,nlev,aklev,bklev,aklay,bklay,error)
c-----------------------------------------------------------------------
c Purpose:
c This routine is called to get the level arrays aklev and
c bklev from a NetCDF constants file.
c Arguments:
c cstid int input identifier for NetCDF constants file
c nlev int input number of levels
c aklev real output array contains all aklev values
c bklev real output array contains all bklev values
c aklay real output array contains all aklay values
c bklay real output array contains all bklay values
c error int output error flag
c error = 0 no errors detected
c error = 1 error detected
c History:
c Aug. 93 Heini Wernli Created.
c-----------------------------------------------------------------------
integer error
integer cstid
integer ncdid,ncvid ! NetCDF functions
integer didz,idak,idbk,idaky,idbky
integer nlev
real aklev(nlev),bklev(nlev),aklay(nlev),bklay(nlev)
character*(20) dimnam
integer i
didz =ncdid(cstid,'nz',error)
if (error.ne.0) goto 920
idak =ncvid(cstid,'aklev',error)
if (error.ne.0) goto 920
idbk =ncvid(cstid,'bklev',error)
if (error.ne.0) goto 920
idaky =ncvid(cstid,'aklay',error)
if (error.ne.0) goto 920
idbky =ncvid(cstid,'bklay',error)
if (error.ne.0) goto 920
call ncdinq(cstid,didz,dimnam,nlev,error) ! read number of levels
if (error.ne.0) goto 920
do 10 i=1,nlev
call ncvgt1(cstid,idak,i,aklev(i),error) ! get aklev
call ncvgt1(cstid,idbk,i,bklev(i),error) ! get bklev
call ncvgt1(cstid,idaky,i,aklay(i),error) ! get aklay
call ncvgt1(cstid,idbky,i,bklay(i),error) ! get bklay
if (error.ne.0) goto 920
10 continue
return
c Error exits.
920 write(*,*)'*ERROR*: An error occured in subroutine getlevs'
return
end
subroutine getntim(cdfid,ntimes,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get number of times on the specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C ntimes int output number of times on the file
C error int output errorflag
C History:
C Heini Wernli, ETHZ
C------------------------------------------------------------------------
include "netcdf.inc"
integer ierr
integer didtim,ntimes
integer cdfid,idtime
integer ncopts
character*(20) dimnam
c Get current value of error options, and make sure netCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt(NCVERBOS)
didtim=ncdid(cdfid,'time',ierr) ! inquire id for time dimension
if (ierr.ne.0) goto 900
idtime=ncvid(cdfid,'time',ierr) ! inquire id for time array
if (ierr.ne.0) goto 900
call ncdinq(cdfid,didtim,dimnam,ntimes,ierr) ! inquire # of times
if (ierr.ne.0) goto 900
c normal exit
call ncpopt (ncopts)
return
c error exit
900 ntimes=1
call ncpopt (ncopts)
end
subroutine getstart(cdfid,idate,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get start date for fields on specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C idate int output array contains date (year,month,day,time,step)
C dimensioned as idate(5)
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
c variable declarations
integer ierr
integer idate(5)
integer cdfid,ncopts,idvar,nvars
integer ndims,ngatts,recdim,i,vartyp,nvatts,vardim(4)
character*20 vnam(100)
c Get current value of error options, and make sure NetCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt (NCVERBOS)
idvar=ncvid(cdfid,'starty',ierr)
if (ierr.ne.0) goto 930
call ncvgt1(cdfid,idvar,1,idate(1),ierr)
if (ierr.ne.0) goto 920
idvar=ncvid(cdfid,'startm',ierr)
if (ierr.ne.0) goto 920
call ncvgt1(cdfid,idvar,1,idate(2),ierr)
if (ierr.ne.0) goto 920
idvar=ncvid(cdfid,'startd',ierr)
if (ierr.ne.0) goto920
call ncvgt1(cdfid,idvar,1,idate(3),ierr)
if (ierr.ne.0) goto 920
idvar=ncvid(cdfid,'starth',ierr)
if (ierr.ne.0) goto 920
call ncvgt1(cdfid,idvar,1,idate(4),ierr)
if (ierr.ne.0) goto 920
C Starts is not defined on all files
C Only ask for it if it exists
C Inquire number of dimensions, variables and attributes
idate(5)=0
call ncinq(cdfid,ndims,nvars,ngatts,recdim,ierr)
do i=1,nvars
call ncvinq(cdfid,i,vnam(i),vartyp,ndims,vardim,nvatts,ierr)
if (vnam(i).eq.'starts') then
idvar=ncvid(cdfid,'starts',ierr)
call ncvgt1(cdfid,idvar,1,idate(5),ierr)
if (ierr.ne.0) goto 920
endif
enddo
c normal exit
call ncpopt (ncopts)
return
c error exit
920 continue
write (6, *) 'ERROR: An error occurred while attempting to ',
& 'read the starting-time in subroutine putstart.'
930 continue
call ncpopt (ncopts)
end
subroutine putstart(cdfid,idate,ierr)
C----------------------------------------------------------------------
C Purpose:
C Puts the 'starting-time' on the specified NetCDF file.
C Arguments:
C cdfid int input identifier for NetCDF file
C idate int input array contains date (year,month,day,time,step)
C dimensioned as idate(5)
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
c variable declarations
integer ierr,idate(5),startid(5),cdfid,ncopts,i
c Get current value of error options, and make sure NetCDF-errors do
c not abort execution
call ncgopt (ncopts)
call ncpopt (NCVERBOS)
c define variables
call ncredf(cdfid,ierr)
if (ierr.ne.0) goto 920
startid(1) = ncvdef (cdfid, 'starty', NCLONG, 0, 0, ierr)
if (ierr.ne.0) goto 920
startid(2) = ncvdef (cdfid, 'startm', NCLONG, 0, 0, ierr)
if (ierr.ne.0) goto 920
startid(3) = ncvdef (cdfid, 'startd', NCLONG, 0, 0, ierr)
if (ierr.ne.0) goto 920
startid(4) = ncvdef (cdfid, 'starth', NCLONG, 0, 0, ierr)
if (ierr.ne.0) goto 920
startid(5) = ncvdef (cdfid, 'starts', NCLONG, 0, 0, ierr)
if (ierr.ne.0) goto 920
call ncendf(cdfid, ierr)
if (ierr.ne.0) goto 920
c store variables
do i=1,5
call ncvpt1(cdfid,startid(i),1,idate(i),ierr)
if (ierr.ne.0) goto 920
enddo
c synchronyse output to disk, revert to previous error-mode, and exit
call ncsnc (cdfid,ierr)
call ncpopt (ncopts)
return
c error exit
920 write (6, *) 'ERROR: An error occurred while attempting to ',
& 'write the starting-time in subroutine putstart.'
call ncpopt (ncopts)
call ncclos (cdfid, ierr)
end
subroutine getgrid(cdfid,dx,dy,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get grid increments for fields on specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C dx real output grid increment along latitude
C dy real output grid increment along longitude
C ierr int output error flag
C------------------------------------------------------------------------
integer ierr
integer cdfid
integer ncvid
integer idilon,idilat
real dx,dy
idilon =ncvid(cdfid,'dellon',ierr)
if (ierr.ne.0) return
idilat =ncvid(cdfid,'dellat',ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idilon,1,dx,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idilat,1,dy,ierr)
if (ierr.ne.0) return
end
subroutine getdattyp(cdfid,typ,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get data type for specified NetCDF file
C Arguments:
C cdfid int input identifier for NetCDF file
C typ int output data type: 1 (52) for pressure (theta) coord
C ierr int output error flag
C------------------------------------------------------------------------
integer ierr
integer cdfid
integer ncvid
integer idtyp,typ
idtyp =ncvid(cdfid,'dattyp',ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idtyp,1,typ,ierr)
if (ierr.ne.0) return
end
subroutine getpole(cdfid,pollon,pollat,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get physical coordinates of pole of coordinate system
C Arguments:
C cdfid int input identifier for NetCDF file
C pollon real output longitude of pole
C pollat real output latitude of pole
C ierr int output error flag
C------------------------------------------------------------------------
integer ierr
integer cdfid
integer ncvid
integer idplon,idplat
real pollon,pollat
idplon =ncvid(cdfid,'pollon',ierr)
if (ierr.ne.0) return
idplat =ncvid(cdfid,'pollat',ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idplon,1,pollon,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idplat,1,pollat,ierr)
if (ierr.ne.0) return
end
subroutine getmc2grid(cdfid,polx,poly,delx,shem,phi0,lam0,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get physical coordinates of pole of coordinate system
C Arguments:
C cdfid int input identifier for NetCDF file
C ierr int output error flag
C------------------------------------------------------------------------
integer ierr
integer cdfid
integer ncvid
integer idpolx,idpoly,iddelx,idshem,idphi0,idlam0
real polx,poly,delx,shem,phi0,lam0
idpolx =ncvid(cdfid,'polx',ierr)
if (ierr.ne.0) return
idpoly =ncvid(cdfid,'poly',ierr)
if (ierr.ne.0) return
iddelx =ncvid(cdfid,'delx',ierr)
if (ierr.ne.0) return
idshem =ncvid(cdfid,'shem',ierr)
if (ierr.ne.0) return
idphi0 =ncvid(cdfid,'phi0',ierr)
if (ierr.ne.0) return
idlam0 =ncvid(cdfid,'lam0',ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idpolx,1,polx,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idpoly,1,poly,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,iddelx,1,delx,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idshem,1,shem,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idphi0,1,phi0,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idlam0,1,lam0,ierr)
if (ierr.ne.0) return
end
subroutine getcfn(cdfid,cfn,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get name of constants file
C Arguments:
C cdfid int input identifier for NetCDF file
C cfn char output name of constants file
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
integer ierr
integer cdfid,lenstr
character*80 cfn
lenstr=80
call ncagtc(cdfid,NCGLOBAL,"constants_file_name",cfn,lenstr,ierr)
if (ierr.ne.0) write(*,*)'error in SR getcfn'
end
subroutine gettype(cdfid,dattyp,datver,cstver,ierr)
C------------------------------------------------------------------------
C Purpose:
C Get data type information from constants file
C Arguments:
C cdfid int input identifier for NetCDF file
C dattyp int output data type
C datver int output data version
C cstver int output constants file version
C------------------------------------------------------------------------
integer ierr
integer cdfid
integer ncvid
integer idtyp,idver,idcstv
integer dattyp,datver,cstver
idtyp =ncvid(cdfid,'dattyp',ierr)
if (ierr.ne.0) return
idver =ncvid(cdfid,'datver',ierr)
if (ierr.ne.0) return
idcstv =ncvid(cdfid,'cstver',ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idtyp,1,dattyp,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idver,1,datver,ierr)
if (ierr.ne.0) return
call ncvgt1(cdfid,idcstv,1,cstver,ierr)
if (ierr.ne.0) return
end
subroutine getvars(cdfid,nvars,vnam,ierr)
C------------------------------------------------------------------------
C Opens the NetCDF file 'filnam' and returns its identifier cdfid.
C filnam char input name of NetCDF file to open
C nvars int output number of variables on file
C vnam char output array with variable names
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
integer cdfid,ierr,nvars
character*(*) vnam(*)
integer ndims,ngatts,recdim,i,vartyp,nvatts,vardim(4)
call ncpopt(NCVERBOS)
C Inquire number of dimensions, variables and attributes
call ncinq(cdfid,ndims,nvars,ngatts,recdim,ierr)
C Inquire variable names from NetCDF file
do i=1,nvars
call ncvinq(cdfid,i,vnam(i),vartyp,ndims,vardim,nvatts,ierr)
enddo
return
end
subroutine cdfopn(filnam,cdfid,ierr)
C------------------------------------------------------------------------
C Opens the NetCDF file 'filnam' and returns its identifier cdfid.
C filnam char input name of NetCDF file to open
C cdfid int output identifier of NetCDF file
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
integer cdfid,ierr
character*(*) filnam
call ncpopt(NCVERBOS)
cdfid=ncopn(trim(filnam),NCNOWRIT,ierr)
return
end
subroutine cdfwopn(filnam,cdfid,ierr)
C------------------------------------------------------------------------
C Opens the NetCDF file 'filnam' and returns its identifier cdfid.
C filnam char input name of NetCDF file to open
C cdfid int output identifier of NetCDF file
C ierr int output error flag
C------------------------------------------------------------------------
include "netcdf.inc"
integer cdfid,ierr
character*(*) filnam
call ncpopt(NCVERBOS)
cdfid=ncopn(trim(filnam),NCWRITE,ierr)
return
end
subroutine gettra(cdfid,varnam,ix,iy,iz,ntimes,array,ierr)
C------------------------------------------------------------------------
C
C Reads the time-evolution for one grid-point of the variable
C indicated by varnam.
C
C cdfid int input identifier for NetCDF file
C varnam char input name of variable
C ix int input x-index for values to read
C iy int input y-index for values to read
C iz int input z-index for values to read
C ntimes int input number of time-indices to read
C array real output array contains the readed values
C ierr int output error flag
C------------------------------------------------------------------------
C Declaration of attributes
integer cdfid
character*(*) varnam
integer ix,iy,iz
integer ntimes
real array(ntimes)
C Declaration of local variables
integer corner(4),edgeln(4)
integer idvar,ierr
integer ncvid
corner(1)=ix
corner(2)=iy
corner(3)=iz
corner(4)=1
edgeln(1)=1
edgeln(2)=1
edgeln(3)=1
edgeln(4)=ntimes
idvar =ncvid(cdfid,varnam,ierr)
call ncvgt(cdfid,idvar,corner,edgeln,array,ierr)
if (ierr.ne.0) goto 991
return
991 stop 'Variable not found on NetCDF file in SR gettra'
end
subroutine new_gettra(cdfid,varnam,ix,ntimes,array,ierr)
C------------------------------------------------------------------------
C
C Reads the time-evolution for one grid-point of the variable
C indicated by varnam.
C
C cdfid int input identifier for NetCDF file
C varnam char input name of variable
C ix int input index for trajectory to read
C ntimes int input number of time-indices to read
C array real output array contains the readed values
C ierr int output error flag
C------------------------------------------------------------------------
C Declaration of attributes
integer cdfid
character*(*) varnam
integer ix
integer ntimes
real array(ntimes)
C Declaration of local variables
integer corner(4),edgeln(4)
integer idvar,ierr
integer ncvid
corner(1)=ix
corner(2)=1
corner(3)=1
corner(4)=1
edgeln(1)=1
edgeln(2)=1
edgeln(3)=1
edgeln(4)=ntimes
idvar =ncvid(cdfid,trim(varnam),ierr)
call ncvgt(cdfid,idvar,corner,edgeln,array,ierr)
if (ierr.ne.0) goto 991
return
991 stop 'Variable not found on NetCDF file in SR new_gettra'
end
subroutine puttra(cdfid,varnam,ix,ntimes,array,ierr)
C------------------------------------------------------------------------
C
C Writes the time-evolution for one grid-point of the variable
C indicated by varnam.
C
C cdfid int input identifier for NetCDF file
C varnam char input name of variable
C ix int input index for trajectory to read
C ntimes int input number of time-indices to read
C array real output array contains the readed values
C ierr int output error flag
C------------------------------------------------------------------------
C Declaration of attributes
integer cdfid
character*(*) varnam
integer ix
integer ntimes
real array(ntimes)
C Declaration of local variables
integer corner(4),edgeln(4)
integer idvar,ierr
integer ncvid
corner(1)=1
corner(2)=1
corner(3)=1
corner(4)=ix
edgeln(1)=ntimes
edgeln(2)=1
edgeln(3)=1
edgeln(4)=1
idvar =ncvid(cdfid,varnam,ierr)
call ncvpt(cdfid,idvar,corner,edgeln,array,ierr)
if (ierr.ne.0) goto 991
return
991 stop 'Could not write data on NetCDF file in SR puttra'
end
subroutine getakbk(nlev,flev,akbk,nn,aklev,bklev,aklay,bklay)
C------------------------------------------------------------------------
C
C Defines the level- and layer-arrays given the number of levels nlev.
C
C nlev int input number of levels/layers wanted
C akbk real input array contains ak/bk values from grib (zsec2)
C nn int input number of elements in array akbk
C aklev real output array contains ak values for levels
C bklev real output array contains bk values for levels
C aklay real output array contains ak values for layers
C bklay real output array contains bk values for layers
C------------------------------------------------------------------------
integer nn,nz,nlev,k
real aklev(100),bklev(100), ! level coefficients
> aklay(100),bklay(100), ! layer coefficients
> akbk(nn)
real ak(100),bk(100)
real flev
C Determine number of levels in array akbk
do k=1,nn
if (akbk(k).eq.1.0) nz=(k-12)/2
enddo
c print*,nlev,nz
do k=1,nz+1
ak(k)=akbk(k+10)/100.
bk(k)=akbk(k+11+nz)
enddo
do k=1,nz
aklay(k)=(ak(nz+2-k)+ak(nz+1-k))/2.
bklay(k)=(bk(nz+2-k)+bk(nz+1-k))/2.
aklev(k)=ak(nz+1-k)
bklev(k)=bk(nz+1-k)
c if (k.eq.2) print*,'bugfix ',bklev(2)
enddo
c do k=1,nz
c print*,k,flev,bk(nz+1-k),aklev(k),aklay(k),bklev(k),bklay(k)
c enddo
return
end
subroutine modlevs(nlev,aklev,bklev,aklay,bklay)
C------------------------------------------------------------------------
C
C Defines the level- and layer-arrays given the number of levels nlev.
C
C nlev int input number of levels/layers
C aklev real output array contains ak values for levels
C bklev real output array contains bk values for levels
C aklay real output array contains ak values for layers
C bklay real output array contains bk values for layers
C------------------------------------------------------------------------
integer n19,n31,n50,nlev,k
parameter(n19=20,n31=32,n50=51) ! number of model levels
real aklev(nlev+1),bklev(nlev+1), ! level coefficients
> aklay(nlev+1),bklay(nlev+1) ! layer coefficients
real ak19(n19),bk19(n19), ! 19 level version
> ak31(n31),bk31(n31), ! 31 level version
> ak50(n50),bk50(n50) ! 50 level version
C Modell level specification for 19 level version
DATA AK19/0,20,40,60,83,106,128,146,158,161,153,136,111,
> 82,52,26,8,0,0,0/
DATA BK19/0,0,0,0,.004,.014,.035,.072,.127,.202,.296,.405,
> .524,.645,.759,.856,.929,.973,.992,1./
C Modell level specification for 31 level version
DATA AK31/
> 0.000000, 20.00000000, 40.00000000, 60.00000000,
> 80.000000, 99.76135361, 118.20539617, 134.31393926,
> 147.363569, 156.89207458, 162.66610500, 164.65005734,
> 162.976193, 157.91598604, 149.85269630, 139.25517858,
> 126.652916, 112.61228878, 97.71406290, 82.53212096,
> 67.613413, 53.45914240, 40.50717678, 29.11569385,
> 19.548052, 11.95889791, 6.38148911, 2.71626545,
> .720635, 0.00000000, 0.00000000, 0.00000000/
DATA BK31/
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0003908582, 0.0029197006, 0.0091941320,
> 0.0203191555, 0.0369748598, 0.0594876397, 0.0878949492,
> 0.1220035886, 0.1614415235, 0.2057032385, 0.2541886223,
> 0.3062353873, 0.3611450218, 0.4182022749, 0.4766881754,
> 0.5358865832, 0.5950842740, 0.6535645569, 0.7105944258,
> 0.7654052430, 0.8171669567, 0.8649558510, 0.9077158297,
> 0.9442132326, 0.9729851852, 0.9922814815, 1.0000000000/
C Modell level specification for 50 level version
DATA AK50/
> 0.0000, .200061, .432978,
> .753462, 1.150821, 1.618974, 2.158969,
> 2.780058, 3.501381, 4.355622, 5.396513,
> 6.686154, 8.283989, 10.263669, 12.716445,
> 15.755378, 19.520544, 24.185498, 29.965266,
> 37.126262, 45.998554, 56.991132, 69.983867,
> 85.074101, 101.817070, 118.830898, 134.429140,
> 147.363554, 156.892070, 162.666093, 164.650039,
> 162.976210, 157.915976, 149.852695, 139.255195,
> 126.652968, 112.612304, 97.714062, 82.532109,
> 67.613398, 53.459179, 40.507187, 29.115703,
> 19.548046, 11.958906, 6.381484, 2.716250,
> .720625, 0.000000, 0.000000, 0.000000/
DATA BK50/
> 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0000000000, 0.0000000000, 0.0000000000, 0.0000000000,
> 0.0001003604, 0.0006727143, 0.0031633405, 0.0092923380,
> 0.0203191563, 0.0369748585, 0.0594876409, 0.0878949761,
> 0.1220036149, 0.1614415050, 0.2057032585, 0.2541885972,
> 0.3062353730, 0.3611450195, 0.4182022810, 0.4766881466,
> 0.5358865857, 0.5950842500, 0.6535645723, 0.7105944157,
> 0.7654052377, 0.8171669841, 0.8649558425, 0.9077158570,
> 0.9442132115, 0.9729852080, 0.9922814965, 1.0000000000/
do k=1,nlev
if (nlev.eq.19) then
aklay(k)=(ak19(nlev+2-k)+ak19(nlev+1-k))/2. ! layi=(levi+levi+1)/2
bklay(k)=(bk19(nlev+2-k)+bk19(nlev+1-k))/2.
aklev(k)=ak19(nlev+1-k) ! reverse order of coeffs for IVE
bklev(k)=bk19(nlev+1-k)
elseif (nlev.eq.31) then
aklay(k)=(ak31(nlev+2-k)+ak31(nlev+1-k))/2. ! layi=(levi+levi+1)/2
bklay(k)=(bk31(nlev+2-k)+bk31(nlev+1-k))/2.
aklev(k)=ak31(nlev+1-k) ! reverse order of coeffs for IVE
bklev(k)=bk31(nlev+1-k)
elseif (nlev.eq.50) then
aklay(k)=(ak50(nlev+2-k)+ak50(nlev+1-k))/2. ! layi=(levi+levi+1)/2
bklay(k)=(bk50(nlev+2-k)+bk50(nlev+1-k))/2.
aklev(k)=ak50(nlev+1-k) ! reverse order of coeffs for IVE
bklev(k)=bk50(nlev+1-k)
else
stop'*** invalid number of modellevels ***'
endif
enddo
if (nlev.eq.19) then
aklay(nlev+1)=ak19(1)/2.
bklay(nlev+1)=bk19(1)/2.
aklev(nlev+1)=ak19(1)
bklev(nlev+1)=bk19(1)
elseif (nlev.eq.31) then
aklay(nlev+1)=ak31(1)/2.
bklay(nlev+1)=bk31(1)/2.
aklev(nlev+1)=ak31(1)
bklev(nlev+1)=bk31(1)
elseif (nlev.eq.50) then
aklay(nlev+1)=ak50(1)/2.
bklay(nlev+1)=bk50(1)/2.
aklev(nlev+1)=ak50(1)
bklev(nlev+1)=bk50(1)
else
stop'*** invalid number of modellevels ***'
endif
* print*,aklev(1),aklev(2),aklev(3),aklev(4),aklev(5),aklev(6)
return
end
subroutine prelevs(nlev,level,aklev,bklev,aklay,bklay)
C------------------------------------------------------------------------
C
C Defines the (dummy-) ak- and bk-arrays given the array that
C contains all pressure levels.
C
C nlev int input number of pressure levels
C level real input pressure levels
C aklev real output array contains ak values for levels
C bklev real output array contains bk values for levels
C aklay real output array contains ak values for layers
C bklay real output array contains bk values for layers
C------------------------------------------------------------------------
integer nlev,k
real aklev(nlev),bklev(nlev), ! level coefficients
> aklay(nlev),bklay(nlev), ! layer coefficients
> level(nlev+1)
do k=1,nlev
aklay(k)=level(k)
bklay(k)=0.
if (nlev.eq.1) then
aklev(k)=level(k)
else
aklev(k)=0.5*(level(k)+level(k+1))
endif
bklev(k)=0.
enddo
return
end
subroutine cpp_cdfwopn(filnam,filnam_len,cdfid,ierr)
C------------------------------------------------------------------------
C Purpose:
C allows to call cdfopn from c++
C Arguments:
C see crecdf
C additionally: filnam_len, the length of the
C string
C
C
C History:
C 981221 Mark A. Liniger ETHZ
C
C Note:
C
C
C------------------------------------------------------------------------
integer filnam_len,cdfid,ierr
character *(*) filnam
call cdfwopn(filnam(1:filnam_len),cdfid,ierr)
end
subroutine getdim (cdfid, varnam, nx, ny, nz, error)
c-------------------------------------------------------------------------
c Purpose:
c This routine is called to get the dimensions of
c a variable from an IVE-NetCDF file for use with the IVE plotting
c package. Prior to calling this routine, the file must be opened
c with a call to opncdf.
c Arguments:
c cdfid int input file-identifier
c (can be obtained by calling routine
c opncdf)
c varnam char input the user-supplied variable name.
c (can be obtained by calling routine
c opncdf)
c nx int output the zonal dimension of the variable.
c ny int output the meridional dimension of the variable.
c nz int output the vertical dimension of the variable.
c
c error int output indicates possible errors found in this
c routine.
c error = 0 no errors detected.
c error = 1 the variable is not on the file.
c error =10 other errors.
c History:
c March 2000 Heini Wernli (ETHZ) Created.
c-----------------------------------------------------------------------
include "netcdf.inc"
c Argument declarations.
character *(*) varnam
integer vardim(4), ndim, error, cdfid
integer nx,ny,nz
c Local variable declarations.
character *(20) dimnam(MAXNCDIM),vnam
integer id,i,k
integer ndims,nvars,ngatts,recdim,dimsiz(MAXNCDIM)
integer vartyp,nvatts, ncopts
c Get current value of error options.
call ncgopt (ncopts)
c make sure NetCDF-errors do not abort execution
call ncpopt(NCVERBOS)
c Initially set error to indicate no errors.
error = 0
c inquire for number of dimensions
call ncinq(cdfid,ndims,nvars,ngatts,recdim,error)
if (error.eq.1) goto 920
c read dimension-table
do i=1,ndims
call ncdinq(cdfid,i,dimnam(i),dimsiz(i),error)
if (error.gt.0) goto 920
enddo
c get id of the variable
id=ncvid(cdfid,varnam,error)
if (error.eq.1) goto 910
c inquire about variable
call ncvinq(cdfid,id,vnam,vartyp,ndim,vardim,nvatts,error)
if (vartyp.ne.NCFLOAT) error=1
if (error.gt.0) goto 920
c get dimensions from dimension-table
do k=1,ndim
vardim(k)=dimsiz(vardim(k))
enddo
nx=vardim(1)
ny=vardim(2)
nz=vardim(3)
c normal exit
call ncpopt (ncopts)
return
c Error exits.
910 write (6, *) '*ERROR*: The selected variable could not be found ',
& 'in the file by getdim.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
return
920 write (6, *) '*ERROR*: An error occurred while attempting to ',
& 'read the data file in subroutine getcdf.'
call ncpopt (ncopts)
call ncclos (cdfid, error)
end
subroutine rvarfile(vnam,gribnr,levty,unit,factor,bias,
> lnum,stg,tdep,p,lval,varcnt,ierr)
C =======================================================
C Variablen-File in Arrays einlesen
integer maxvar
parameter(maxvar=100)
character*(15) vnam(maxvar)
character*(13) unit(maxvar)
character*(1) flag
integer gribnr(maxvar),levty(maxvar),lnum(maxvar),
> stg(maxvar),tdep(maxvar),p(maxvar),lval(maxvar)
real factor(maxvar),bias(maxvar)
integer i,varcnt,ierr,nt
nt=14 ! number of tape
i=1 ! initialize var-counter
C Read first character of row and decide if it is comment or not
100 read(nt,10,err=123,end=126) flag
if (flag.eq."#") goto 100 ! don't bother about comments
backspace nt
121 read(nt,122, err=123, end=126) vnam(i), gribnr(i), levty(i),
& unit(i), factor(i), bias(i), lnum(i), stg(i), tdep(i), p(i),
& lval(i)
i=i+1
* goto 100
goto 121
10 format(a1)
122 format(a14,i3,i11,a17,f7.5,f9.2,i7,i4,i6,i3,i5)
* 123 print *,'*ERROR* in subroutine rvarfile'
123 goto 121
126 continue
varcnt=i-1 ! # of variables in varfile_i
C Check some things
ierr=0 ! initialize error flag
do i=1,varcnt
if ((lnum(i).ne.1).and.(lnum(i).ne.2).and.(lnum(i).ne.3)
> .and.(lnum(i).ne.4)) ierr=11
if ((stg(i).ne.0).and.(stg(i).ne.1).and.(stg(i).ne.10).and.
> (stg(i).ne.11)) ierr=12
if ((tdep(i).ne.0).and.(tdep(i).ne.1)) ierr=13
if ((p(i).ne.0).and.(p(i).ne.1).and.(p(i).ne.2)) ierr=14
if ((lval(i).lt.0).or.(lval(i).gt.1050)) ierr=15
enddo
return
end

/tags/1.0/lib/times.f
0,0 → 1,296
c **************************************************************************
c * This library provides subroutines related to time and file name *
c * handling *
c * *
c **************************************************************************
c ---------------------------------------------------------------------------
c Concatenate a date string
c ---------------------------------------------------------------------------
subroutine datestring(datestr,yyyy,mm,dd,hh)
c Declaration of subroutine parameters
integer yyyy,mm,dd,hh
character*20 datestr
c Auxiliary parameters
integer f1,f2,i0
integer yy,ce
i0=ichar('0')
datestr=''
yy=mod(yyyy,100)
ce=int(yyyy/100)
if ((ce.ne.19).and.(ce.ne.20).and.(ce.ne.18)) then
print*,'Invalid century... Stop'
stop
endif
if (yy.ge.0) then
f1=yy/10
f2=mod(yy,10)
if (ce.eq.18) then
datestr=trim(datestr)//'18'//char(f1+i0)//char(f2+i0)
else if (ce.eq.19) then
datestr=trim(datestr)//'19'//char(f1+i0)//char(f2+i0)
else if (ce.eq.20) then
datestr=trim(datestr)//'20'//char(f1+i0)//char(f2+i0)
endif
endif
if (mm.gt.0) then
f1=mm/10
f2=mod(mm,10)
datestr=trim(datestr)//char(f1+i0)//char(f2+i0)
endif
if (dd.gt.0) then
f1=dd/10
f2=mod(dd,10)
datestr=trim(datestr)//char(f1+i0)//char(f2+i0)
endif
if (hh.ge.0) then
f1=hh/10
f2=mod(hh,10)
datestr=trim(datestr)//'_'//char(f1+i0)//char(f2+i0)
endif
return
end
c ---------------------------------------------------------------------------
c Calculates the new date when diff (in hours) is added to date1.
c ---------------------------------------------------------------------------
subroutine newdate(date1,diff,date2)
C
C date1 int input array contains a date in the form
C year,month,day,hour,step
C diff real input timestep in hours to go from date1
C date2 int output array contains new date in the same form
integer date1(5),date2(5)
integer idays(12) ! array containing the days of the monthes
real diff
logical yearchange
data idays/31,28,31,30,31,30,31,31,30,31,30,31/
yearchange=.false.
if ((mod(date1(1),4).eq.0).and.(date1(2).le.2)) idays(2)=29
date2(1)=date1(1)
date2(2)=date1(2)
date2(3)=date1(3)
date2(4)=date1(4)
date2(5)=0
date2(4)=date1(4)+int(diff)+date1(5)
if (date2(4).ge.24) then
date2(3)=date2(3)+int(date2(4)/24)
date2(4)=date2(4)-int(date2(4)/24)*24
endif
if (date2(4).lt.0) then
if (mod(date2(4),24).eq.0) then
date2(3)=date2(3)-int(abs(date2(4))/24)
date2(4)=date2(4)+int(abs(date2(4))/24)*24
else
date2(3)=date2(3)-(1+int(abs(date2(4))/24))
date2(4)=date2(4)+(1+int(abs(date2(4))/24))*24
endif
endif
100 if (date2(3).gt.idays(date2(2))) then
if ((date2(2).eq.2).and.(mod(date2(1),4).eq.0)) idays(2)=29
date2(3)=date2(3)-idays(date2(2))
if (idays(2).eq.29) idays(2)=28
date2(2)=date2(2)+1
if (date2(2).gt.12) then
* date2(1)=date2(1)+int(date2(2)/12)
* date2(2)=date2(2)-int(date2(2)/12)*12
date2(1)=date2(1)+1
date2(2)=date2(2)-12
endif
if (date2(2).lt.1) then
date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
endif
goto 100
endif
200 if (date2(3).lt.1) then
date2(2)=date2(2)-1
if (date2(2).gt.12) then
date2(1)=date2(1)+int(date2(2)/12)
date2(2)=date2(2)-int(date2(2)/12)*12
endif
if (date2(2).lt.1) then
date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
endif
if ((date2(2).eq.2).and.(mod(date2(1),4).eq.0)) idays(2)=29
date2(3)=date2(3)+idays(date2(2))
if (idays(2).eq.29) idays(2)=28
goto 200
endif
if (date2(2).gt.12) then
date2(1)=date2(1)+int(date2(2)/12)
date2(2)=date2(2)-int(date2(2)/12)*12
endif
if (date2(2).lt.1) then
date2(1)=date2(1)-(1+int(abs(date2(2)/12)))
date2(2)=date2(2)+(1+int(abs(date2(2)/12)))*12
endif
if (date2(1).lt.1000) then
if (date2(1).ge.100) date2(1)=date2(1)-100
endif
return
end
c ---------------------------------------------------------------------------
c Convert <hh.mm> -> <frac> and <frac> -> <hhmm>
c ---------------------------------------------------------------------------
subroutine hhmm2frac (hhmm,frac)
real hhmm
real frac
frac=real(int(hhmm))+
> 100.*(hhmm-real(int(hhmm)))/60.
end
subroutine frac2hhmm (frac,hhmm)
real hhmm
real frac
real hh,mm
hh = real(int(frac))
mm = 60. * (frac-real(int(frac)))
hhmm = hh + 0.01 * mm
end
c ---------------------------------------------------------------------------
c Time difference between two dates
c ---------------------------------------------------------------------------
subroutine timediff(date1,date2,diff)
C New version with hour and minutes! (for hour and step [in hours]
C use the routine oldtimediff!)
C
C Calculates the time difference in hours (and minutes) for the two
C dates specified by the two arrays date1 and date2.
C They are expected to contain the following date information:
C year month day hour minute.
C
C date1 array specifying the first date
C date2 array specifying the second date
C diff time differenc between date1 and date2 in hours
C
integer date1(5),date2(5)
integer idays(12) ! array containing the days of the monthes
real diff
integer ixday,imdiff,ihdiff,iddiff,j
integer yy,yy1,yy2
idays(1)=31
idays(2)=28
idays(3)=31
idays(4)=30
idays(5)=31
idays(6)=30
idays(7)=31
idays(8)=31
idays(9)=30
idays(10)=31
idays(11)=30
idays(12)=31
C Check format of year (YYYY or YY - in case of YY assume 19YY)
if (date1(1).lt.100) date1(1)=1900+date1(1)
if (date2(1).lt.100) date2(1)=1900+date2(1)
C Determine if the period between date1 and date2 contains a Feb.29
ixday=0 ! extra day flag
yy1=min(date1(1),date2(1))
yy2=max(date1(1),date2(1))
if (yy1.eq.yy2) then
if (mod(yy1,4).eq.0) then
idays(2)=29
endif
else
if (mod(yy1,4).eq.0) then
if (((yy1.eq.date1(1)).and.(date1(2).le.2)).or.
> ((yy1.eq.date2(1)).and.(date2(2).le.2))) then
ixday=ixday+1
endif
endif
if (mod(yy2,4).eq.0) then
if (((yy2.eq.date1(1)).and.(date1(2).gt.2)).or.
> ((yy2.eq.date2(1)).and.(date2(2).gt.2))) then
ixday=ixday+1
endif
endif
if (yy2-yy1.gt.1) then
do yy=yy1+1,yy2-1
if (mod(yy,4).eq.0) then
ixday=ixday+1
endif
enddo
endif
endif
ihdiff=0 ! diff. in hours between date1/date2
iddiff=0 ! diff. in days between date1/date2
if (date1(1).gt.date2(1)) then ! compare years
do j=date2(1),date1(1)-1
iddiff=iddiff+365
enddo
iddiff=iddiff+ixday
else if (date1(1).lt.date2(1)) then
do j=date1(1),date2(1)-1
iddiff=iddiff-365
enddo
iddiff=iddiff-ixday
endif
if (date1(2).gt.date2(2)) then ! compare monthes
do j=date2(2),date1(2)-1
iddiff=iddiff+idays(j)
enddo
else if (date1(2).lt.date2(2)) then
do j=date1(2),date2(2)-1
iddiff=iddiff-idays(j)
enddo
endif
iddiff=iddiff+date1(3)-date2(3)
ihdiff=iddiff*24+date1(4)-date2(4)
imdiff=ihdiff*60+date1(5)-date2(5)
ihdiff=imdiff/60
imdiff=mod(imdiff,60)
diff=real(ihdiff)+real(imdiff)/100.
return
end

/tags/1.0/lidar/lidar.f
0,0 → 1,1350
PROGRAM trace
C ********************************************************************
C * *
C * Pseudo-lidar plots along trajectories *
C * *
C * Heini Wernli first version: April 1993 *
C * Michael Sprenger major upgrade: 2008-2009 *
C * *
C ********************************************************************
implicit none
c --------------------------------------------------------------------
c Declaration of parameters
c --------------------------------------------------------------------
c Maximum number of levels for input files
integer nlevmax
parameter (nlevmax=100)
c Maximum number of input files (dates, length of trajectories)
integer ndatmax
parameter (ndatmax=500)
c Numerical epsilon (for float comparison)
real eps
parameter (eps=0.001)
c Conversion factors
real pi180 ! deg -> rad
parameter (pi180=3.14159/180.)
real deg2km ! deg -> km (at equator)
parameter (deg2km=111.)
c Prefix for primary and secondary fields
character charp
character chars
parameter (charp='P')
parameter (chars='S')
c --------------------------------------------------------------------
c Declaration of variables
c --------------------------------------------------------------------
c Input and output format for trajectories (see iotra.f)
integer inpmode
c Input parameters
character*80 inpfile ! Input trajectory file
character*80 outfile ! Output netCDF file
character*80 outmode ! Output mode (sum,mean)
integer ntra ! Number of trajectories
integer ncol ! Number of columns (including time, lon, lat, p)
integer ntim ! Number of times per trajectory
integer ntrace0 ! Number of trace variables
character*80 tvar(200) ! Tracing variable name (only the variable)
character*1 tfil(200) ! Filename prefix
real fac(200) ! Scaling factor
integer compfl(200) ! Computation flag (1=compute)
integer numdat ! Number of input files
character*11 dat(ndatmax) ! Dates of input files
real timeinc ! Time increment between input files
real tst ! Time shift of start relative to first data file
real ten ! Time shift of end relatiev to first data file
character*20 startdate ! First time/date on trajectory
character*20 enddate ! Last time/date on trajectory
character*80 timecheck ! Either 'yes' or 'no'
character*80 intmode ! Interpolation mode ('normal', 'nearest')
real pmin,pmax ! Pressure range for output grid
integer npre ! Number of pressure levels in output grid
character*80 centering ! Centering around trajectory position ('yes','no')
character*80 direction ! Direction of lidar (vertical,lat,lon,normal)
character*80 dumpcoord ! Dumping coordinates ('yes','no')
c Trajectories
real,allocatable, dimension (:,:,:) :: trainp ! Input trajectories (ntra,ntim,ncol)
integer reftime(6) ! Reference date
character*80 varsinp(100) ! Field names for input trajectory
integer fid,fod ! File identifier for inp and out trajectories
real x0_tra,y0_tra,p0_tra ! Position of air parcel (physical space)
real reltpos0 ! Relative time of air parcel
real xind,yind,pind ! Position of air parcel (grid space)
integer fbflag ! Flag for forward (1) or backward (-1) trajectories
c Meteorological fields from input file
real,allocatable, dimension (:) :: spt0,spt1 ! Surface pressure
real,allocatable, dimension (:) :: p3t0,p3t1 ! 3d-pressure
real,allocatable, dimension (:) :: f3t0,f3t1 ! 3d field for tracing
character*80 svars(100) ! List of variables on S file
character*80 pvars(100) ! List of variables on P file
integer n_svars ! Number of variables on S file
integer n_pvars ! Number of variables on P file
c Input grid description
real pollon,pollat ! Longitude/latitude of pole
real ak(100) ! Vertical layers and levels
real bk(100)
real xmin,xmax ! Zonal grid extension
real ymin,ymax ! Meridional grid extension
integer nx,ny,nz ! Grid dimensions
real dx,dy ! Horizontal grid resolution
integer hem ! Flag for hemispheric domain
integer per ! Flag for periodic domain
real stagz ! Vertical staggering
real mdv ! Missing data value
c Output grid and fields
real levels(1000) ! Ouput levels
real times (1000) ! Output times
real,allocatable, dimension (:,:) :: out_pos ! Position of trajectories
real,allocatable, dimension (:,:) :: out_val ! Output lidar field
real,allocatable, dimension (:,:) :: out_cnt ! # output lidar sum ups
c Auxiliary variables
integer i,j,k,l,n
real rd
character*80 filename
real time0,time1,reltpos
integer itime0,itime1
integer stat
real tstart
integer iloaded0,iloaded1
real f0
real frac
real tload,tfrac
integer isok
character ch
integer ind
integer ind1,ind2,ind3,ind4,ind5
integer ind6,ind7,ind8,ind9,ind0
integer noutside
real delta
integer itrace0
character*80 string
character*80 cdfname
character*80 varname
real time
character*80 longname
character*80 unit
integer ind_time
integer ind_pre
real rlat,rlon
real x0,y0,p0
real vx0,vy0,vx1,vy1
real rotation,lon,lat
c Externals
real int_index4
external int_index4
c --------------------------------------------------------------------
c Start of program, Read parameters, get grid parameters
c --------------------------------------------------------------------
c Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM LIDAR ***'
print*
c Read parameters
open(10,file='trace.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) outmode
read(10,*) startdate
read(10,*) enddate
read(10,*) fbflag
read(10,*) numdat
if ( fbflag.eq.1) then
do i=1,numdat
read(10,'(a11)') dat(i)
enddo
else
do i=numdat,1,-1
read(10,'(a11)') dat(i)
enddo
endif
read(10,*) timeinc
read(10,*) tst
read(10,*) ten
read(10,*) ntra
read(10,*) ntim
read(10,*) ncol
read(10,*) ntrace0
do i=1,ntrace0
read(10,*) tvar(i), fac(i), compfl(i), tfil(i)
enddo
read(10,*) n_pvars
do i=1,n_pvars
read(10,*) pvars(i)
enddo
read(10,*) n_svars
do i=1,n_svars
read(10,*) svars(i)
enddo
read(10,*) timecheck
read(10,*) intmode
read(10,*) pmin,pmax,npre
read(10,*) centering
read(10,*) direction
read(10,*) dumpcoord
close(10)
c Check that the direction is ok
if ( ( direction.ne.'vertical' ).and.
> ( direction.ne.'lat' ).and.
> ( direction.ne.'lon' ).and.
> ( direction.ne.'normal' ) )
>then
print*,' ERROR: invalid direction ',trim(direction)
stop
endif
c Remove commented tracing fields
itrace0 = 1
do while ( itrace0.le.ntrace0)
string = tvar(itrace0)
if ( string(1:1).eq.'#' ) then
do i=itrace0,ntrace0-1
tvar(i) = tvar(i+1)
fac(i) = fac(i+1)
compfl(i) = compfl(i+1)
tfil(i) = tfil(i+1)
enddo
ntrace0 = ntrace0 - 1
else
itrace0 = itrace0 + 1
endif
enddo
c Set the formats of the input files
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
C Convert time shifts <tst,ten> from <hh.mm> into fractional time
call hhmm2frac(tst,frac)
tst = frac
call hhmm2frac(ten,frac)
ten = frac
c Set the time for the first data file (depending on forward/backward mode)
if (fbflag.eq.1) then
tstart = -tst
else
tstart = tst
endif
c Read the constant grid parameters (nx,ny,nz,xmin,xmax,ymin,ymax,pollon,pollat)
c The negative <-fid> of the file identifier is used as a flag for parameter retrieval
filename = charp//dat(1)
varname = 'U'
call input_open (fid,filename)
call input_grid (-fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tstart,pollon,pollat,rd,rd,nz,rd,rd,rd,timecheck)
call input_close(fid)
C Allocate memory for some meteorological arrays
allocate(spt0(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt0 ***' ! Surface pressure
allocate(spt1(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt1 ***'
allocate(p3t0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t0 ***' ! Pressure
allocate(p3t1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
allocate(f3t0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t0 ***' ! Lidar field
allocate(f3t1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
c Allocate memory for output field
allocate(out_pos(ntim,npre),stat=stat)
if (stat.ne.0) print*,'*** error allocating array out_pos ***'
allocate(out_val(ntim,npre),stat=stat)
if (stat.ne.0) print*,'*** error allocating array out_val ***'
allocate(out_cnt(ntim,npre),stat=stat)
if (stat.ne.0) print*,'*** error allocating array out_cnt ***'
C Get memory for trajectory arrays
allocate(trainp(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra ***'
c Set the flags for periodic domains
if ( abs(xmax-xmin-360.).lt.eps ) then
per = 1
elseif ( abs(xmax-xmin-360.+dx).lt.eps ) then
per = 2
else
per = 0
endif
C Set logical flag for periodic data set (hemispheric or not)
hem = 0
if (per.eq.0.) then
delta=xmax-xmin-360.
if (abs(delta+dx).lt.eps) then ! Program aborts: arrays must be closed
print*,' ERROR: arrays must be closed... Stop'
else if (abs(delta).lt.eps) then ! Periodic and hemispheric
hem=1
per=360.
endif
else ! Periodic and hemispheric
hem=1
endif
c Write some status information
print*,'---- INPUT PARAMETERS -----------------------------------'
print*
print*,' Input trajectory file : ',trim(inpfile)
print*,' Format of input file : ',inpmode
print*,' Output netCDF file : ',trim(outfile)
print*,' Format of output file : ',trim(outmode)
print*,' Forward/backward : ',fbflag
print*,' #tra : ',ntra
print*,' #col : ',ncol
print*,' #tim : ',ntim
print*,' No time check : ',trim(timecheck)
print*,' Interpolation mode : ',trim(intmode)
do i=1,ntrace0
if (compfl(i).eq.0) then
print*,' Tracing field : ',
> trim(tvar(i)), fac(i), ' 0 ', tfil(i)
else
print*,' Tracing field : ',
> trim(tvar(i)),' : online calc not supported'
endif
enddo
print*,' Output (pmin,pmax,n) : ',pmin,pmax,npre
print*,' Centering : ',trim(centering)
print*,' Orientation : ',trim(direction)
print*,' Coordinate Dump : ',trim(dumpcoord)
print*
print*,'---- INPUT DATA FILES -----------------------------------'
print*
call frac2hhmm(tstart,tload)
print*,' Time of 1st data file : ',tload
print*,' #input files : ',numdat
print*,' time increment : ',timeinc
call frac2hhmm(tst,tload)
print*,' Shift of start : ',tload
call frac2hhmm(ten,tload)
print*,' Shift of end : ',tload
print*,' First/last input file : ',trim(dat(1)),
> ' ... ',
> trim(dat(numdat))
print*,' Primary variables : ',trim(pvars(1))
do i=2,n_pvars
print*,' : ',trim(pvars(i))
enddo
if ( n_svars.ge.1 ) then
print*,' Secondary variables : ',trim(svars(1))
do i=2,n_svars
print*,' : ',trim(svars(i))
enddo
endif
print*
print*,'---- CONSTANT GRID PARAMETERS ---------------------------'
print*
print*,' xmin,xmax : ',xmin,xmax
print*,' ymin,ymax : ',ymin,ymax
print*,' dx,dy : ',dx,dy
print*,' pollon,pollat : ',pollon,pollat
print*,' nx,ny,nz : ',nx,ny,nz
print*,' per, hem : ',per,hem
print*
c --------------------------------------------------------------------
c Load the input trajectories
c --------------------------------------------------------------------
c Read the input trajectory file
call ropen_tra(fid,inpfile,ntra,ntim,ncol,reftime,varsinp,inpmode)
call read_tra (fid,trainp,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Check that first four columns correspond to time,lon,lat,p
if ( (varsinp(1).ne.'time' ).or.
> (varsinp(2).ne.'xpos' ).and.(varsinp(2).ne.'lon' ).or.
> (varsinp(3).ne.'ypos' ).and.(varsinp(3).ne.'lat' ).or.
> (varsinp(4).ne.'ppos' ).and.(varsinp(4).ne.'p' ) )
>then
print*,' ERROR: problem with input trajectories ...'
stop
endif
varsinp(1) = 'time'
varsinp(2) = 'lon'
varsinp(3) = 'lat'
varsinp(4) = 'p'
c Write some status information of the input trajectories
print*,'---- INPUT TRAJECTORIES ---------------------------------'
print*
print*,' Start date : ',trim(startdate)
print*,' End date : ',trim(enddate)
print*,' Reference time (year) : ',reftime(1)
print*,' (month) : ',reftime(2)
print*,' (day) : ',reftime(3)
print*,' (hour) : ',reftime(4)
print*,' (min) : ',reftime(5)
print*,' Time range (min) : ',reftime(6)
do i=1,ncol
print*,' Var :',i,trim(varsinp(i))
enddo
print*
c Check that first time is 0 - otherwise the tracing will produce
c wrong results because later in the code only absolute times are
c considered: <itime0 = int(abs(tfrac-tstart)/timeinc) + 1>. This
c will be changed in a future version.
if ( abs( trainp(1,1,1) ).gt.eps ) then
print*,' ERROR: First time of trajectory must be 0, i.e. '
print*,' correspond to the reference date. Otherwise'
print*,' the tracing will give wrong results... STOP'
stop
endif
c If requested, open the coordinate dump file
if ( dumpcoord.eq.'yes' ) then
open(10,file=trim(outfile)//'.coord')
endif
c --------------------------------------------------------------------
c Trace the fields (fields available on input files)
c --------------------------------------------------------------------
print*
print*,'---- LIDAR FROM PRIMARY AND SECONDARY DATA FILES ------'
c Loop over all tracing fields
do i=1,ntrace0
c Skip all fields marked for online calculation
if ( compfl(i).eq.1 ) goto 110
c Init the output fields: position and lidar field
do k=1,ntim
do l=1,npre
out_pos(k,l) = 0.
out_val(k,l) = 0.
out_cnt(k,l) = 0.
enddo
enddo
c Write some status information
print*
print*,' Now lidaring : ',
> trim(tvar(i)),compfl(i),' ',trim(tfil(i))
c Reset flags for load manager
iloaded0 = -1
iloaded1 = -1
c Reset the counter for fields outside domain
noutside = 0
c Loop over all times
do j=1,ntim
c Convert trajectory time from hh.mm to fractional time
call hhmm2frac(trainp(1,j,1),tfrac)
c Get the times which are needed
itime0 = int(abs(tfrac-tstart)/timeinc) + 1
time0 = tstart + fbflag * real(itime0-1) * timeinc
itime1 = itime0 + 1
time1 = time0 + fbflag * timeinc
if ( itime1.gt.numdat ) then
itime1 = itime0
time1 = time0
endif
c Load manager: Check whether itime0 can be copied from itime1
if ( itime0.eq.iloaded1 ) then
f3t0 = f3t1
p3t0 = p3t1
spt0 = spt1
iloaded0 = itime0
endif
c Load manager: Check whether itime1 can be copied from itime0
if ( itime1.eq.iloaded0 ) then
f3t1 = f3t0
p3t1 = p3t0
spt1 = spt0
iloaded1 = itime1
endif
c Load manager: Load first time (tracing variable and grid)
if ( itime0.ne.iloaded0 ) then
filename = tfil(i)//dat(itime0)
call frac2hhmm(time0,tload)
varname = tvar(i)
write(*,'(a23,a20,a3,a5,f7.2)')
> ' -> loading : ',
> trim(filename),' ',trim(varname),tload
call input_open (fid,filename)
call input_wind
> (fid,varname,f3t0,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,p3t0,spt0,nz,ak,bk,stagz,
> timecheck)
call input_close(fid)
iloaded0 = itime0
endif
c Load manager: Load second time (tracing variable and grid)
if ( itime1.ne.iloaded1 ) then
filename = tfil(i)//dat(itime1)
call frac2hhmm(time1,tload)
varname = tvar(i)
write(*,'(a23,a20,a3,a5,f7.2)')
> ' -> loading : ',
> trim(filename),' ',trim(varname),tload
call input_open (fid,filename)
call input_wind
> (fid,varname,f3t1,tload,stagz,mdv,
> xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid
> (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
> tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz,
> timecheck)
call input_close(fid)
iloaded1 = itime1
endif
c Loop over all trajectories
do k=1,ntra
c Set the trajectory position
x0_tra = trainp(k,j,2) ! Longitude
y0_tra = trainp(k,j,3) ! Latitude
p0_tra = trainp(k,j,4) ! Pressure
c Get rotation angle - orient normal to trajectory
if ( direction.eq.'normal' ) then
vx0 = 1.
vy0 = 0.
if ( j.lt.ntim ) then
lat = 0.5 * ( trainp(k,j,3) + trainp(k,j+1,3) )
vx1 = ( trainp(k,j+1,2) - trainp(k,j,2) ) *
> cos( lat * pi180 )
vy1 = ( trainp(k,j+1,3) - trainp(k,j,3) )
else
lat = 0.5 * ( trainp(k,j,3) + trainp(k,j-1,3) )
vx1 = ( trainp(k,j,2) - trainp(k,j-1,2) ) *
> cos( lat * pi180 )
vy1 = ( trainp(k,j,3) - trainp(k,j-1,3) )
endif
if ( vx1.gt.180 ) vx1 = vx1 - 360
if ( vx1.lt.-180 ) vx1 = vx1 + 360.
call getangle (vx0,vy0,vx1,vy1,rotation)
rotation = -rotation
else
rotation = 0.
endif
c Set the relative time
call hhmm2frac(trainp(k,j,1),tfrac)
reltpos0 = fbflag * (tfrac-time0)/timeinc
c Loop over pressure profile (or other positions for horizontal mode)
do l=1,npre
c Vertical
if ( direction.eq.'vertical' ) then
x0 = x0_tra
y0 = y0_tra
p0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
if ( centering.eq.'yes' )then
p0 = p0 + trainp(k,j,4)
endif
c Longitude
elseif ( direction.eq.'lon' ) then
x0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
y0 = y0_tra
p0 = p0_tra
if ( centering.eq.'yes' )then
x0 = x0 + x0_tra
endif
c Latitude
elseif ( direction.eq.'lat' ) then
x0 = x0_tra
y0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
p0 = p0_tra
if ( centering.eq.'yes' )then
y0 = y0 + y0_tra
endif
c Normal to trajerctory
elseif ( direction.eq.'normal' ) then
c Set the coordinate in the rotated system
rlat = pmin +
> real(l-1)/real(npre-1) * (pmax-pmin)
rlon = 0.
c Transform it back to geographical lon/lat
call getenvir_b (x0_tra,y0_tra,rotation,
> x0,y0,rlon,rlat,1)
c Pressure unchanged
p0 = p0_tra
endif
c Handle periodic boundaries in zonal direction
if ( (x0.gt.xmax).and.(per.ne.0) ) x0 = x0 - 360.
if ( (x0.lt.xmin).and.(per.ne.0) ) x0 = x0 + 360.
c Handle pole problems for hemispheric data (taken from caltra.f)
if ((hem.eq.1).and.(y0.gt.90.)) then
y0=180.-y0
x0=x0+per/2.
endif
if ((hem.eq.1).and.(y0.lt.-90.)) then
y0=-180.-y0
x0=x0+per/2.
endif
if (y0.gt.89.99) then
y0=89.99
endif
c If requested, dump the lidar coordinates
if ( (dumpcoord.eq.'yes').and.(i.eq.1) ) then
write(10,'(3f10.2)') x0,y0,trainp(k,j,1)
write(10,'(3f10.2)') x0_tra,y0_tra,5.
endif
C Get the index where to interpolate (x0,y0,p0)
if ( (abs(x0-mdv).gt.eps).and.
> (abs(y0-mdv).gt.eps) )
> then
call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0,
> p3t0,p3t1,spt0,spt1,3,
> nx,ny,nz,xmin,ymin,dx,dy,mdv)
else
xind = mdv
yind = mdv
pind = mdv
endif
c If requested, apply nearest-neighbor interpolation
if ( intmode.eq.'nearest') then
xind = real( nint(xind) )
yind = real( nint(yind) )
pind = real( nint(pind) )
if ( xind.lt.1. ) xind = 1.
if ( xind.gt.nx ) xind = real(nx)
if ( yind.lt.1. ) yind = 1.
if ( yind.gt.ny ) yind = real(ny)
if ( pind.lt.1. ) pind = 1.
if ( pind.gt.nz ) pind = real(nz)
endif
c Do the interpolation: everthing is ok
if ( (xind.ge.1.).and.(xind.le.real(nx)).and.
> (yind.ge.1.).and.(yind.le.real(ny)).and.
> (pind.ge.1.).and.(pind.le.real(nz)) )
> then
f0 = int_index4(f3t0,f3t1,nx,ny,nz,
> xind,yind,pind,reltpos0,mdv)
c Set to missing data
else
f0 = mdv
endif
c Save result to output array
if (abs(f0-mdv).gt.eps) then
out_val(j,l) = out_val(j,l) + f0 * fac(i)
out_cnt(j,l) = out_cnt(j,l) + 1.
endif
c End loop over all pressure levels
enddo
c Save output - time index
ind_time = j
c Save output - space index for 'no centering'
if ( centering.eq.'no' ) then
if ( direction.eq.'vertical') then
ind_pre = nint( real(npre) *
> ( (p0_tra - pmin)/(pmax-pmin) ) + 1.)
elseif ( direction.eq.'lon') then
ind_pre = nint( real(npre) *
> ( (x0_tra - pmin)/(pmax-pmin) ) + 1.)
elseif ( direction.eq.'lat') then
ind_pre = nint( real(npre) *
> ( (y0_tra - pmin)/(pmax-pmin) ) + 1.)
endif
c Save output - space index for 'centering'
else
ind_pre = nint( real(npre) *
> ( (0. - pmin)/(pmax-pmin) ) + 1.)
endif
c Update the output array
if ( (ind_time.ge.1).and.(ind_time.le.ntim).and.
> (ind_pre .ge.1).and.(ind_pre .le.npre) )
> then
out_pos(ind_time,ind_pre) =
> out_pos(ind_time,ind_pre) + 1.
endif
c End loop over all trajectories
enddo
c End loop over all times
enddo
c Write the trajectory position to netCDF file - only once
if ( i.eq.1 ) then
cdfname = outfile
varname = 'POSITION'
longname = 'position of trajectory points'
unit = 'none'
time = 0.
do k=1,npre
levels(k) = pmin + real(k-1)/real(npre-1) * (pmax-pmin)
enddo
do k=1,ntim
times(k) = trainp(1,k,1)
enddo
call writecdf2D_cf
> (cdfname,varname,longname,unit,out_pos,time,levels,
> times,npre,ntim,1,1,direction)
endif
c If no valid lidar count: set the field to missing data
do k=1,ntim
do l=1,npre
if (abs(out_cnt(k,l)).lt.eps) then
out_val(k,l) = mdv
endif
enddo
enddo
c If requested, calculate the mean of the lidar field
if ( outmode.eq.'mean' ) then
do k=1,ntim
do l=1,npre
if ( (abs(out_val(k,l)-mdv).gt.eps).and.
> (abs(out_cnt(k,l) ).gt.0. ) )
> then
out_val(k,l) = out_val(k,l) / out_cnt(k,l)
endif
enddo
enddo
endif
c Write the lidar field and count
cdfname = outfile
if (outmode.eq.'sum' ) then
varname = trim(tvar(i))//'_SUM'
elseif (outmode.eq.'mean' ) then
varname = trim(tvar(i))//'_MEAN'
endif
longname = 'sum over all '//trim(tvar(i))//' profiles'
unit = 'not given'
time = 0.
call writecdf2D_cf
> (cdfname,varname,longname,unit,out_val,time,levels,
> times,npre,ntim,0,1,direction)
cdfname = outfile
varname = trim(tvar(i))//'_CNT'
longname = 'counts of all '//trim(tvar(i))//' profiles'
unit = 'not given'
time = 0.
call writecdf2D_cf
> (cdfname,varname,longname,unit,out_cnt,time,levels,
> times,npre,ntim,0,1,direction)
c Exit point for loop over all tracing variables
110 continue
c End loop over all lidar variables
enddo
c --------------------------------------------------------------------
c Write output to netCDF file
c --------------------------------------------------------------------
c Write status information
print*
print*,'---- WRITE OUTPUT LIDAR FIELDS --------------------------'
print*
c Close coord dump file
print*,' LIDAR written to : ',trim(outfile)
if ( dumpcoord.eq.'yes' ) then
print*,' Coordinates dumped to : ',trim(outfile)//'.coord'
endif
c Write some status information, and end of program message
print*
print*,'---- STATUS INFORMATION --------------------------------'
print*
print*,' ok'
print*
print*,' *** END OF PROGRAM LIDAR ***'
print*,'========================================================='
end
c ********************************************************************
c * INPUT / OUTPUT SUBROUTINES *
c ********************************************************************
c --------------------------------------------------------------------
c Subroutines to write 2D CF netcdf output file
c --------------------------------------------------------------------
subroutine writecdf2D_cf
> (cdfname,varname,longname,unit,arr,time,levels,times,
> npre,ntim,crefile,crevar,direction)
c Create and write to the CF netcdf file <cdfname>. The variable
c with name <varname> and with time <time> is written. The data
c are in the two-dimensional array <arr>. The flags <crefile> and
c <crevar> determine whether the file and/or the variable should
c be created.
USE netcdf
IMPLICIT NONE
c Declaration of input parameters
character*80 cdfname
character*80 varname,longname,unit
integer npre,ntim
real arr(ntim,npre)
real levels(npre)
real times (ntim)
real time
integer crefile,crevar
character*80 direction
c Numerical epsilon
real eps
parameter (eps=1.e-5)
c Local variables
integer ierr
integer ncID
integer LevDimId, varLevID
integer TimeDimID, varTimeID
real timeindex
integer i,j
integer nvars,varids(100)
integer ndims,dimids(100)
real timelist(1000)
integer ntimes
integer ind
integer varID
c Quick an dirty solution for fieldname conflict
if ( varname.eq.'time' ) varname = 'TIME'
c Initially set error to indicate no errors.
ierr = 0
c ---- Create the netCDF - skip if <crefile=0> ----------------------
if ( crefile.ne.1 ) goto 100
c Create the file
ierr = nf90_create(trim(cdfname), NF90_CLOBBER, ncID)
c Define dimensions
ierr=nf90_def_dim(ncID,'level',npre, LevDimID )
ierr=nf90_def_dim(ncID,'time' ,ntim, TimeDimID)
c Define space coordinate
ierr = nf90_def_var(ncID,'level',NF90_FLOAT,
> (/ LevDimID /),varLevID)
if ( direction.eq.'vertical' ) then
ierr = nf90_put_att(ncID, varLevID, "standard_name","level")
ierr = nf90_put_att(ncID, varLevID, "units" ,"hPa")
elseif ( direction.eq.'lat' ) then
ierr = nf90_put_att(ncID, varLevID, "standard_name","latitude")
ierr = nf90_put_att(ncID, varLevID, "units" ,"deg")
elseif ( direction.eq.'lon' ) then
ierr = nf90_put_att(ncID, varLevID, "standard_name","longitude")
ierr = nf90_put_att(ncID, varLevID, "units" ,"deg")
elseif ( direction.eq.'normal' ) then
ierr = nf90_put_att(ncID, varLevID, "standard_name","normal")
ierr = nf90_put_att(ncID, varLevID, "units" ,"deg")
endif
c Define time coordinate
ierr = nf90_def_var(ncID,'time',NF90_FLOAT,
> (/ TimeDimID /), varTimeID)
ierr = nf90_put_att(ncID, varTimeID, "long_name", "time")
ierr = nf90_put_att(ncID, varTimeID, "units", "hours")
c Write global attributes
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'Conventions', 'CF-1.0')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'title',
> 'pseudo-lidar from trajectory file')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'source',
> 'Lagranto Trajectories')
ierr = nf90_put_att(ncID, NF90_GLOBAL, 'institution',
> 'ETH Zurich, IACETH')
c Check whether the definition was successful
ierr = nf90_enddef(ncID)
if (ierr.gt.0) then
print*, 'An error occurred while attempting to ',
> 'finish definition mode.'
stop
endif
c Write coordinate data
ierr = nf90_put_var(ncID,varLevID ,levels)
ierr = nf90_put_var(ncID,varTimeID ,times )
c Close netCDF file
ierr = nf90_close(ncID)
100 continue
c ---- Define a new variable - skip if <crevar=0> -----------------------
if ( crevar.ne.1 ) goto 110
print*,'Now defining ',trim(varname)
c Open the file for read/write access
ierr = nf90_open (trim(cdfname), NF90_WRITE , ncID)
c Get the IDs for dimensions
ierr = nf90_inq_dimid(ncID,'level', LevDimID )
ierr = nf90_inq_dimid(ncID,'time' , TimeDimID)
c Enter define mode
ierr = nf90_redef(ncID)
c Write definition and add attributes
ierr = nf90_def_var(ncID,varname,NF90_FLOAT,
> (/ TimeDimID, LevDimID /),varID)
ierr = nf90_put_att(ncID, varID, "long_name" , longname )
ierr = nf90_put_att(ncID, varID, "units" , unit )
ierr = nf90_put_att(ncID, varID, '_FillValue', -999.99 )
c Check whether definition was successful
ierr = nf90_enddef(ncID)
if (ierr.gt.0) then
print*, 'An error occurred while attempting to ',
> 'finish definition mode.'
stop
endif
c Close netCDF file
ierr = nf90_close(ncID)
110 continue
c ---- Write data --------------------------------------------------
c Open the file for read/write access
ierr = nf90_open (trim(cdfname), NF90_WRITE , ncID)
c Get the varID
ierr = nf90_inq_varid(ncID,varname, varID )
if (ierr.ne.0) then
print*,'Variable ',trim(varname),' is not defined on ',
> trim(cdfname)
stop
endif
c Write data block
ierr = nf90_put_var(ncID,varID,arr,
> start = (/ 1, 1 /),
> count = (/ ntim, npre/) )
c Check whether writing was successful
ierr = nf90_close(ncID)
if (ierr.ne.0) then
write(*,*) trim(nf90_strerror(ierr))
write(*,*) 'An error occurred while attempting to ',
> 'close the netcdf file.'
write(*,*) 'in clscdf_CF'
endif
end
c ********************************************************************************
c * Coordinate rotation - lidar normal to trajectory *
c ********************************************************************************
c --------------------------------------------------------------------------------
c Backward coordinate transformation (Rotated lon/lat -> True lon/lat)
c --------------------------------------------------------------------------------
SUBROUTINE getenvir_b (clon,clat,rotation,
> lon,lat,rlon,rlat,n)
implicit none
c Declaration of input and output parameters
integer n
real clon,clat,rotation
real lon(n), lat(n)
real rlon(n),rlat(n)
c Auxiliary variables
real pollon,pollat
integer i
real rlon1(n),rlat1(n)
c Externals
real lmstolm,phstoph
external lmstolm,phstoph
c First coordinate transformation (make the local coordinate system parallel to equator)
pollon=-180.
pollat=90.+rotation
do i=1,n
rlon1(i)=90.+lmstolm(rlat(i),rlon(i)-90.,pollat,pollon)
rlat1(i)=phstoph(rlat(i),rlon(i)-90.,pollat,pollon)
enddo
c Second coordinate transformation (make the local coordinate system parallel to equator)
pollon=clon-180.
if (pollon.lt.-180.) pollon=pollon+360.
pollat=90.-clat
do i=1,n
lon(i)=lmstolm(rlat1(i),rlon1(i),pollat,pollon)
lat(i)=phstoph(rlat1(i),rlon1(i),pollat,pollon)
enddo
END
c ---------------------------------------------------------------------
c Determine the angle between two vectors
c ---------------------------------------------------------------------
SUBROUTINE getangle (vx1,vy1,vx2,vy2,angle)
c Given two vectors <vx1,vy1> and <vx2,vy2>, determine the angle (in deg)
c between the two vectors.
implicit none
c Declaration of subroutine parameters
real vx1,vy1
real vx2,vy2
real angle
c Auxiliary variables and parameters
real len1,len2,len3
real val1,val2,val3
real pi
parameter (pi=3.14159265359)
len1=sqrt(vx1*vx1+vy1*vy1)
len2=sqrt(vx2*vx2+vy2*vy2)
if ((len1.gt.0.).and.(len2.gt.0.)) then
vx1=vx1/len1
vy1=vy1/len1
vx2=vx2/len2
vy2=vy2/len2
val1=vx1*vx2+vy1*vy2
val2=-vy1*vx2+vx1*vy2
len3=sqrt(val1*val1+val2*val2)
if ( (val1.ge.0.).and.(val2.ge.0.) ) then
val3=acos(val1/len3)
else if ( (val1.lt.0.).and.(val2.ge.0.) ) then
val3=pi-acos(abs(val1)/len3)
else if ( (val1.ge.0.).and.(val2.le.0.) ) then
val3=-acos(val1/len3)
else if ( (val1.lt.0.).and.(val2.le.0.) ) then
val3=-pi+acos(abs(val1)/len3)
endif
else
val3=0.
endif
angle=180./pi*val3
END
c --------------------------------------------------------------------------------
c Transformation routine: LMSTOLM and PHSTOPH from library gm2em
c --------------------------------------------------------------------------------
REAL FUNCTION LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C
C**** LMSTOLM - FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C**** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : LAM = LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C** IM ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHIS REAL GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C** LAMS REAL GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C** POLPHI REAL WAHRE GEOGR. BREITE DES NORDPOLS
C** POLLAM REAL WAHRE GEOGR. LAENGE DES NORDPOLS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: D.MAJEWSKI
REAL LAMS,PHIS,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHIS = ZPIR18*PHIS
ZLAMS = LAMS
IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
ZLAMS = ZPIR18*ZLAMS
ZARG1 = SIN(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS) +
1 ZCOSPOL* SIN(ZPHIS)) -
2 COS(ZLAMPOL)* SIN(ZLAMS)*COS(ZPHIS)
ZARG2 = COS(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS) +
1 ZCOSPOL* SIN(ZPHIS)) +
2 SIN(ZLAMPOL)* SIN(ZLAMS)*COS(ZPHIS)
IF (ABS(ZARG2).LT.1.E-30) THEN
IF (ABS(ZARG1).LT.1.E-30) THEN
LMSTOLM = 0.0
ELSEIF (ZARG1.GT.0.) THEN
LMSTOLAM = 90.0
ELSE
LMSTOLAM = -90.0
ENDIF
ELSE
LMSTOLM = ZRPI18*ATAN2(ZARG1,ZARG2)
ENDIF
RETURN
END
REAL FUNCTION PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C
C**** PHSTOPH - FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C**** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C**** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : PHI = PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C** EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHIS REAL GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C** LAMS REAL GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C** POLPHI REAL WAHRE GEOGR. BREITE DES NORDPOLS
C** POLLAM REAL WAHRE GEOGR. LAENGE DES NORDPOLS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE BREITE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: D.MAJEWSKI
REAL LAMS,PHIS,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
SINPOL = SIN(ZPIR18*POLPHI)
COSPOL = COS(ZPIR18*POLPHI)
ZPHIS = ZPIR18*PHIS
ZLAMS = LAMS
IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
ZLAMS = ZPIR18*ZLAMS
ARG = COSPOL*COS(ZPHIS)*COS(ZLAMS) + SINPOL*SIN(ZPHIS)
PHSTOPH = ZRPI18*ASIN(ARG)
RETURN
END
REAL FUNCTION LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** LMTOLMS - FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM
C**** AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : LAM = LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM AUF
C** EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHI REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C** LAM REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C** POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C** POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C** AUSGABE-
C** PARAMETER: WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: G. DE MORSIER
REAL LAM,PHI,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHI = ZPIR18*PHI
ZLAM = LAM
IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
ZLAM = ZPIR18*ZLAM
ZARG1 = - SIN(ZLAM-ZLAMPOL)*COS(ZPHI)
ZARG2 = - ZSINPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL)+ZCOSPOL*SIN(ZPHI)
IF (ABS(ZARG2).LT.1.E-30) THEN
IF (ABS(ZARG1).LT.1.E-30) THEN
LMTOLMS = 0.0
ELSEIF (ZARG1.GT.0.) THEN
LMTOLMS = 90.0
ELSE
LMTOLMS = -90.0
ENDIF
ELSE
LMTOLMS = ZRPI18*ATAN2(ZARG1,ZARG2)
ENDIF
RETURN
END
REAL FUNCTION PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** PHTOPHS - FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI
C**** AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**** IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C**** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** AUFRUF : PHI = PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C** ENTRIES : KEINE
C** ZWECK : UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI AUF
C** EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C** ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C** DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C** VERSIONS-
C** DATUM : 03.05.90
C**
C** EXTERNALS: KEINE
C** EINGABE-
C** PARAMETER: PHI REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C** LAM REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C** POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C** POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C** AUSGABE-
C** PARAMETER: ROTIERTE BREITE PHIS ALS WERT DER FUNKTION
C** ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C** COMMON-
C** BLOECKE : KEINE
C**
C** FEHLERBE-
C** HANDLUNG : KEINE
C** VERFASSER: G. DE MORSIER
REAL LAM,PHI,POLPHI,POLLAM
DATA ZRPI18 , ZPIR18 / 57.2957795 , 0.0174532925 /
ZSINPOL = SIN(ZPIR18*POLPHI)
ZCOSPOL = COS(ZPIR18*POLPHI)
ZLAMPOL = ZPIR18*POLLAM
ZPHI = ZPIR18*PHI
ZLAM = LAM
IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
ZLAM = ZPIR18*ZLAM
ZARG = ZCOSPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL) + ZSINPOL*SIN(ZPHI)
PHTOPHS = ZRPI18*ASIN(ZARG)
RETURN
END

/tags/1.0/lidar/lidar.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = lidar.o ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/ioinp.a ${LAGRANTO}/lib/inter.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
lidar: $(OBJS)
${F77} -o lidar $(OBJS) ${INCS} $(LIBS)

/tags/1.0/lidar/lidar.sh
0,0 → 1,624
#!/bin/csh
# ---------------------------------------------------------------------
# Usage, parameter settings
# ---------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( (${#argv} == 0) | (${#argv} < 2) ) then
echo
${LAGRANTO}/bin/lagrantohelp lidar short
echo
exit 0
endif
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR LIDAR *** '
echo
# Get the arguments
set inpfile = $1
set outfile = $2
# Set base directories (run+prog)
set cdfdir=${PWD}
set tradir=${PWD}
# Set program paths and filenames
set parfile = ${tradir}/trace.param
set prog = ${LAGRANTO}/lidar/lidar
# Set the prefix of the primary and secondary data files
set charp = 'P'
set chars = 'S'
echo '---- DIRECTORIES AND PROGRAMS ---------------------------'
echo
echo "CDF directory : ${cdfdir}"
echo "TRA directory : ${tradir}"
echo "PROGRAM LIDAR : ${prog}"
echo "PARAMETER file : ${parfile}"
echo
# ---------------------------------------------------------------------
# Set optional flags
# ---------------------------------------------------------------------
echo '---- OPTIONAL FLAGS -------------------------------------'
echo
# Set some default values ("nil" must be set according to input files)
set flag_i = "nil"
set flag_v = "tracevars"
set flag_f = "nil"
set tvfile = 'tracevars'
set changet = 'false'
set noclean = 'false'
set timecheck = 'no'
set intmode = 'normal'
set pmin = 'nil'
set pmax = 'nil'
set npre = 100
set centering = 'no'
set orientation = 'vertical'
set outmode = 'sum'
set dumpcoord = 'no'
# Set flag for consistency
set isok = 1
set explicit_limits = false
while ( $#argv > 0 )
switch ( $argv[1] )
case -i
set flag_i=$argv[2]
echo "Flag '-i' -> ${flag_i} (user defined)"
shift;
breaksw
case -pmin
set explicit_limits = true
set pmin=$argv[2]
echo "Flag '-pmin' -> pmin (user defined): ${pmin}"
shift;
breaksw
case -pmax
set explicit_limits = true
set pmax=$argv[2]
echo "Flag '-pmax' -> pmax (user defined): ${pmax}"
shift;
breaksw
case -npre
set npre=$argv[2]
echo "Flag '-npre' -> npre (user defined): ${npre}"
shift;
breaksw
case -centering
set centering = 'yes'
echo "Flag '-centering' -> centering (user defined): ${centering}"
breaksw
case -dumpcoord
set dumpcoord = 'yes'
echo "Flag '-dumpcoord' -> dumpcoord (user defined): ${dumpcoord}"
breaksw
case -orientation
set orientation=$argv[2]
echo "Flag '-orientation'-> orientation (user defined): ${orientation}"
shift;
breaksw
case -v
set flag_v="-v"
set tvfile=$argv[2]
echo "Flag '-v' -> ${tvfile} (user defined)"
shift;
if ( $isok == 2 ) set isok = 0
if ( $isok == 1 ) set isok = 2
breaksw
case -f
set flag_f="-f"
set tvfile="tracevars.tmp"
shift;
set tvar="$argv[1]"
shift;
set tscale="$argv[1]"
echo "Flag '-f' -> ${tvar} ${tscale} (user defined)"
if ( $isok == 2 ) set isok = 0
if ( $isok == 1 ) set isok = 2
breaksw
case -changet
set changet = 'true'
echo "changet -> true (user defined)"
breaksw
case -noclean
set noclean = 'true'
echo "noclean -> true (user defined)"
breaksw
case -mean
set outmode = 'mean'
echo "outmode -> mean (user defined)"
breaksw
case -timecheck
set timecheck = 'yes'
echo "timecheck -> yes (user defined)"
breaksw
case -nearest
set intmode = 'nearest'
echo "intmode -> nearest (user defined)"
breaksw
endsw
shift;
end
# For orientation=normal: only centering is reasonable
if ( "${orientation}" == "normal" && "${centering}" == "no" ) then
echo "For horizontal(normal) Lidar, only centering is reasonable - > mode changed"
set centering = 'yes'
endif
# No change of times necessary if no check requested
if ( "${timecheck}" == "no" ) then
set changet = 'false'
endif
# Check consitency of arguments
if ( $isok == 0 ) then
echo
echo " ERROR: Use either option '-v' or '-f', but not both..."
exit 1
endif
# Set position boundaries - pmin,pmax (pressure, lat,lon, deg rotated)
if ( ( "${pmin}" == "nil" ) && ( "${orientation}" == "vertical" ) ) then
set pmin = 100
set pmax = 1000
else if ( ( "${pmin}" == "nil" ) && ( "${orientation}" == "lat" ) ) then
set pmin = -90
set pmax = 90
else if ( ( "${pmin}" == "nil" ) && ( "${orientation}" == "lon" ) ) then
set pmin = -180
set pmax = 180
else if ( ( "${pmin}" == "nil" ) && ( "${orientation}" == "normal" ) ) then
set pmin = -90
set pmax = 90
endif
# If centering is chosen, set reasonable upper and lower limits
if ( ( "$centering" == "yes" ) && ( "${explicit_limits}" == "false" ) ) then
if ( "${orientation}" == "vertical" ) then
set pmin = -500
set pmax = 500
else if ( "${orientation}" == "lat" ) then
set pmin = -10
set pmax = 10
else if ( "${orientation}" == "lon" ) then
set pmin = -10
set pmax = 10
else if ( "${orientation}" == "normal" ) then
set pmin = -10
set pmax = 10
endif
endif
# ---------------------------------------------------------------------
# Handle the input trajectory file
# ---------------------------------------------------------------------
echo
echo '---- TIME RANGE -----------------------------------------'
echo
# Check whether the input file can be found
if ( ! -f ${inpfile} ) then
echo " ERROR : Input file ${inpfile} is missing"
exit 1
endif
# Get the start, end and reference date for the tracing
set startdate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} startdate`
set enddate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} enddate`
set refdate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} refdate`
set ntra = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntra`
set ntim = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntim`
set ncol = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ncol`
# Check format of start and end date - must be the same
set ns=`echo $startdate | sed -e 's/_[0-9]*//' | wc -c`
set ne=`echo $enddate | sed -e 's/_[0-9]*//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( $ns != 9 ) then
echo " ERROR: Date format must be yyyymmdd ***"
exit 1
endif
set ns=`echo $startdate | sed -e 's/[0-9]*_//' | wc -c`
set ne=`echo $enddate | sed -e 's/[0-9]*_//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( ( $ns != 5 ) & ( $ns != 3 ) ) then
echo " ERROR: Time format must be hh(mm) ***"
exit 1
endif
# Split the start and end date into <yymmdd_hh and mm>
set startdate_ymdh = `echo $startdate | cut -c 1-11`
set startdate_min = `echo $startdate | cut -c 12-13`
if ( $startdate_min == "" ) set startdate_min = 00
set enddate_ymdh = `echo $enddate | cut -c 1-11`
set enddate_min = `echo $enddate | cut -c 12-13`
if ( $enddate_min == "" ) set enddate_min = 00
# Get the time difference between <start_ymdh> and <end_ymdh> date
# Decide whether trajectoriesare forward or backward
set timediff_hh = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${startdate_ymdh}`
if ( $timediff_hh == 0 ) then
if ( $enddate_min > $startdate_min ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
endif
else if ( $timediff_hh > 0 ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
@ timediff_hh = $idir * $timediff_hh
endif
# Get also minutes for time difference, if <start_min> or <end_min> != 0
set timediff_mm=
if ( $startdate_min != 00 || $enddate_min != 00 ) then
@ min = ( $enddate_min - $startdate_min )
if ( $min == 0 ) then
set timediff_mm=
else if ( $min > 0 ) then
if ( $idir == 1 ) then
set timediff_mm=$min
else
@ timediff_hh --
@ timediff_mm = 60 - $min
endif
else
if ( $idir == 1 ) then
@ timediff_hh --
@ timediff_mm = 60 + $min
else
@ timediff_mm = 0 - $min
endif
endif
endif
# Write status information
echo "Time range : ${startdate} -> ${enddate}"
if ( ${timediff_mm} != "" ) then
echo "Time difference : ${timediff_hh} h ${timediff_mm} min"
else
echo "Time difference : ${timediff_hh} h"
endif
echo "Direction : ${direction} (${idir})"
# ---------------------------------------------------------------------
# Check availability of input data
# ---------------------------------------------------------------------
echo
echo '---- INPUT FILES ----------------------------------------'
echo
# Take the time increment from flag list ('nil', if not defined)
set timeinc = ${flag_i}
# Find a first data file (if possible corresponding to start/end date
# If starttime is not a data time, take the first file in the direectory
if ( $direction == "f" ) then
set file=${charp}${startdate_ymdh}
else
set file=${charp}${enddate_ymdh}
endif
if ( ! -f $file ) then
set file=`ls ${charp}[0-9_]*[0-9] | head -1 | sed -e 's/@//'`
endif
# Determine timeinc (the time difference in hours between two data file)
# if not already defined with option -i
if ( ${timeinc} == "nil" ) then
set date1=`echo $file | cut -c 2-12`
set n=`ls ${charp}[0-9_]*[0-9] | grep -n $date1 | awk -F: '{print $1}'`
@ n ++
set date2=`ls ${charp}[0-9_]*[0-9] | head -$n | tail -1 | cut -c 2-12`
set timeinc=`${LAGRANTO}/goodies/gettidiff $date2 $date1`
endif
if ( $timeinc == 0 ) then
echo " ERROR: cannot set the time increment between input files ***"
exit 1
endif
# Search the first file to use
set flag=0
set td=
foreach i ( ${charp}????????_?? )
set date = `echo $i | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
end
# if no P/T-files are available for the specified time period, then $td is
# still undefined
if ( $td == "" ) then
echo " ERROR: no data files available for the specified time period"
exit 1
endif
# Everything is fine so far: proceed
label2:
# Check whether first date is ok - before or at needed dates
if ( $direction == "f" ) then
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
else
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
endif
if ( $tdiff0 < 0 ) then
echo " ERROR: data files missing for the specified time period"
exit 1
endif
# Calculate the number of further files
@ num = ( $timediff_hh + $td ) / $timeinc + 1
@ dum1 = ( $num - 1 ) * $timeinc
@ dum2 = $timediff_hh + $td
if ( $dum1 != $dum2 ) @ num ++
# Get a list of all needed files
set numfiles=$num
set sfiles=1
while ( $num > 1 )
set date=`${LAGRANTO}/goodies/newtime $date $timeinc`
if ( ! -f ${charp}${date} ) then
echo " ERROR: file with primary data is missing for $date"
exit 1
else if ( ! -f ${chars}${date} ) then
set sfiles=0
set datfiles=`echo $datfiles $date`
else
set datfiles=`echo $datfiles $date`
endif
@ num --
end
# Calculate the start and the end time relative to the first datfile
if ( $direction == f ) then
set tstart = `${LAGRANTO}/goodies/gettidiff $startdate $datfiles[1]`
set tend = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $enddate`
else
set tstart = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $startdate`
set tend = `${LAGRANTO}/goodies/gettidiff $enddate $datfiles[1]`
endif
# Write some status information
echo "Primary file prefix : ${charp}"
echo "Secondary file prefix : ${chars}"
echo "Time increment for input files : ${timeinc}"
echo "# input files : ${numfiles}"
echo "First input file : $datfiles[1] "
echo "Last input file : $datfiles[$numfiles] "
echo "${charp} files availability : 1"
echo "${chars} files availability : ${sfiles}"
if ( $direction == f ) then
echo "Start time relative to first file : $datfiles[1] + ${tstart} "
echo "End time relative to last file : $datfiles[$numfiles] - ${tend} "
else
echo "Start time relative to last file : $datfiles[$numfiles] - ${tstart} "
echo "End time relative to first file : $datfiles[1] + ${tend} "
endif
# ---------------------------------------------------------------------
# Check availability of input data
# ---------------------------------------------------------------------
echo
echo '---- TRACEVAR FILE --------------------------------------'
echo
# If "-f" option is used, create a temporary tracevar file
if ( "${flag_f}" == "-f" ) then
# Preset values for <compfl> and <tprefix>
set tcompfl=1
set tprefix='P'
# Check availability on P file
foreach var ( `${LAGRANTO}/goodies/getvars ${charp}$datfiles[1]` )
if ( "${var}" == "${tvar}" ) then
set tcompfl=0
set tprefix="P"
endif
end
# Check availability on S file
if ( ${sfiles} == 1 ) then
foreach var ( `${LAGRANTO}/goodies/getvars ${chars}$datfiles[1]` )
if ( "${var}" == "${tvar}" ) then
set tcompfl=0
set tprefix="S"
endif
end
endif
# Write the temporary <tracevars> file
echo "${tvar} ${tscale} ${tcompfl} ${tprefix}" >! ${tvfile}
echo "Temporary tracervar file <${tvfile}> created"
echo
endif
# Check if tracevars-file exists
if ( ! -f $tvfile ) then
echo " ERROR: file $tvfile was not found ***"
exit 1
endif
# check if the variables contained in the tracevars-file are available in the
# data file and check also if there are no empty lines in the tracevars-file
set nlines = `cat $tvfile | wc -l`
set vars = `cat $tvfile | awk '{print $1}'`
set nvars = `echo $vars | wc -w`
if ( $nlines != $nvars ) then
echo " ERROR: tracevars-files must not contain empty lines ***"
exit 1
endif
set calf=`cat $tvfile | awk '{print $3}'`
set tfil=`cat $tvfile | awk '{print $4}'`
foreach v ( $vars )
if ( $calf[1] == 0 ) then
set v0 = `echo $v | awk 'BEGIN {FS = ":"}; {print $1}'`
set flag=`${LAGRANTO}/goodies/getvars $tfil[1]$datfiles[1] | grep " $v0 " | wc -l`
set iscomment=`echo $v0 | cut -c 1`
if ( "${iscomment}" != "#" ) then
if ( $flag == 0 ) then
echo " ERROR: variable $v listed in $tvfile is not on the $tfil[1]-files ***"
exit 1
endif
endif
endif
shift calf
shift tfil
end
set ntrace=${nlines}
# Write some status information
cat ${tvfile}
echo
echo "# Number of tracing variables : ${ntrace}"
# ---------------------------------------------------------------------
# Prepare input file for trace and run it
# ---------------------------------------------------------------------
# Set times relative to the reference date
if ( "${changet}" == "true" ) then
echo
echo '---- CHANGE TIMES ON DATA FILES ------------------------'
echo
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${charp}${i}
end
if ( ${sfiles} == 1 ) then
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${chars}${i}
end
endif
endif
# ---------------------------------------------------------------------
# Prepare input file for lidar and run it
# ---------------------------------------------------------------------
# Write parameter file
\rm -f ${parfile}
touch ${parfile}
echo $inpfile >> $parfile
echo $outfile >> $parfile
echo $outmode >> $parfile
echo $startdate >> $parfile
echo $enddate >> $parfile
echo $idir >> $parfile
echo $numfiles >> $parfile
foreach i ( $datfiles )
echo $i >> $parfile
end
echo $timeinc >> $parfile
echo $tstart >> $parfile
echo $tend >> $parfile
echo $ntra >> $parfile
echo $ntim >> $parfile
echo $ncol >> $parfile
echo $ntrace >> $parfile
cat ${tvfile} >> $parfile
${LAGRANTO}/goodies/getvars ${charp}$datfiles[1] | wc -l >> $parfile
${LAGRANTO}/goodies/getvars ${charp}$datfiles[1] >> $parfile
if ( $sfiles == 1 ) then
${LAGRANTO}/goodies/getvars ${chars}$datfiles[1] | wc -l >> $parfile
${LAGRANTO}/goodies/getvars ${chars}$datfiles[1] >> $parfile
else
echo 0 >> $parfile
endif
echo \"${timecheck}\" >> $parfile
echo \"${intmode}\" >> $parfile
echo ${pmin},${pmax},${npre} >> $parfile
echo \"${centering}\" >> $parfile
echo \"${orientation}\" >> $parfile
echo \"${dumpcoord}\" >> $parfile
# Finish the preprocessor
echo
echo ' *** END OF PREPROCESSOR LIDAR *** '
echo '========================================================='
echo
# Run lidar
${prog}
if ( "${status}" != "0" ) then
echo "ERROR: Program <lidar> failed"
exit 1
endif
# ---------------------------------------------------------------------
# Final tasks (make clean)
# ---------------------------------------------------------------------
finish:
if ( "${noclean}" == "false" ) then
\rm -f ${parfile}
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/select/select.f
0,0 → 1,2199
PROGRAM select
c **************************************************************
c * Select trajectories from LSL file *
c * Michael Sprenger / January, February 2008 *
c **************************************************************
implicit none
c --------------------------------------------------------------
c Declaration of parameters
c --------------------------------------------------------------
c Maximum number of columns per trajectory
integer maxcol
parameter (maxcol=100)
c Maximum number of commands
integer maxcmd
parameter (maxcmd=10000)
c --------------------------------------------------------------
c Declaration of variables
c --------------------------------------------------------------
c Input and output files
character*120 inp_lslfile ! Input lsl file
character*120 out_lslfile ! Output lsl file
character*120 inp_criteria ! Input file with criteria
integer inpmode ! Format of input file
integer outmode ! Format of output file
character*80 outformat ! Trajectory/Boolean/Index of output
character*80 regionf ! Name of the regionfile
c Trajectories
integer ntim ! Number of times
integer ncol ! Number of columns (including time...)
integer ntrainp,ntraout ! Number of trajectories
character*80 vars(maxcol) ! Names of trajectory columns
integer basetime(6) ! Base time of trajectory (first line in lsl)
real,allocatable, dimension (:,:,:) :: trainp ! Input trajectories
real,allocatable, dimension (:,:,:) :: traout ! Output trajectories
integer,allocatable,dimension (:) :: selflag ! Flag for selection
real,allocatable, dimension (:) :: time ! Times of the trajectory
integer,allocatable,dimension (:,:) :: trigger ! Trigger column
integer itrigger ! Column index for trigger
character*80 addtrigger ! Flag whether to add trigger column
c Command stack
real cmd(maxcmd) ! Decoded slection criterion
integer ncmd ! Number of commands
c Common block for initialisation of polygon check
real tlonv(2000),vlat_c(2000),vlon_c(2000)
real xlat_c,xlon_c
integer ibndry,nv_c
data ibndry/0/
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
c Auxiliary variables
integer stat ! Logical (state) variable
integer fid,fod,fcr ! File identifier for input and output
integer i,j,k ! Index counter
integer isok ! Flag for selected trajectory
real param(1000) ! List of parameters
integer nparam ! Number of parameters
character*80 specialstr ! Name of special command
integer len
integer,allocatable,dimension (:) :: trigger1 ! Trigger column
real,allocatable,dimension (:,:) :: trainp1 ! A single trajectory
character ch
c --------------------------------------------------------------
c Preparations
c --------------------------------------------------------------
c Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM SELECT ***'
print*
c Read parameter file
open(10,file='select.param')
read(10,*) inp_lslfile
read(10,*) out_lslfile
read(10,*) outformat
read(10,*) inp_criteria
read(10,*) ntrainp
read(10,*) ntim
read(10,*) ncol
read(10,*) regionf
read(10,*) addtrigger
close(10)
c Set the formats of the input and output files
call mode_tra(inpmode,inp_lslfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,out_lslfile)
if ( (outmode.eq.-1).and.(outformat.ne.'startf') ) then
outmode=1
endif
c Allocate memory for a single trajectory
allocate(trainp(ntrainp,ntim,ncol),stat=stat)
if (stat.ne.0) stop '*** error allocating array trainp ***'
allocate(time(ntim),stat=stat)
if (stat.ne.0) stop '*** error allocating array time ***'
allocate(selflag(ntrainp),stat=stat)
if (stat.ne.0) stop '*** error allocating array selflag ***'
allocate(trigger(ntrainp,ntim),stat=stat)
if (stat.ne.0) stop '*** error allocating array trigger ***'
allocate(trigger1(ntim),stat=stat)
if (stat.ne.0) stop '*** error allocating array trigger1 ***'
allocate(trainp1(ntim,ncol),stat=stat)
if (stat.ne.0) stop '*** error allocating array trainp1 ***'
c Read the input trajectory file
call ropen_tra(fid,inp_lslfile,ntrainp,ntim,ncol,
> basetime,vars,inpmode)
call read_tra (fid,trainp,ntrainp,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
c Check that first four columns correspond to time,lon,lat,p
if ( (vars(1).ne.'time' ).or.
> (vars(2).ne.'xpos' ).and.(vars(2).ne.'lon' ).or.
> (vars(3).ne.'ypos' ).and.(vars(3).ne.'lat' ).or.
> (vars(4).ne.'ppos' ).and.(vars(4).ne.'p' ) )
>then
print*,' ERROR: problem with input trajectories ...'
stop
endif
vars(1) = 'time'
vars(2) = 'lon'
vars(3) = 'lat'
vars(4) = 'p'
c Get the trajectory times from first trajectory
do i=1,ntim
time(i)=trainp(1,i,1)
enddo
c Init the trigger field - first check whether it is already available
itrigger = 0
do i=1,ncol
if ( vars(i).eq.'TRIGGER' ) itrigger = i
enddo
if ( itrigger.ne.0 ) then
do i=1,ntrainp
do j=1,ntim
trigger(i,j) = nint( trainp(i,j,itrigger) )
enddo
enddo
else
do i=1,ntrainp
do j=1,ntim
trigger(i,j) = 0
enddo
enddo
endif
c Write some info about the trajectory
print*,'---- INPUT PARAMETERS -----------------------------------'
write(*,*)
write(*,*) 'Input file : ',trim(inp_lslfile)
write(*,*) 'Output file : ',trim(out_lslfile)
write(*,*) 'Output format : ',trim(outformat)
write(*,*) 'Criteria file : ',trim(inp_criteria)
write(*,*) '# tra : ',ntrainp
write(*,*) '# time : ',ntim
write(*,*) '# col : ',ncol
write(*,*) 'Region file : ',trim(regionf)
write(*,*) 'Add trigger : ',trim(addtrigger)
print*
print*,'---- INPUT TRAJECTORY FILE ------------------------------'
print*
write(*,'(1x,a12,i4,a10)') 'Vars : ',1,trim(vars(1))
do i=2,ncol
write(*,'(1x,a12,i4,a10)') ' ',i,trim(vars(i))
enddo
print*
write(*,'(1x,a12,i4,f10.2)') 'Time : ',1,time(1)
do i=2,ntim
write(*,'(1x,a12,i4,f10.2)') ' ',i,time(i)
enddo
print*
write(*,'(1x,a12,i4,i10)') 'Base date : ',1,basetime(1)
write(*,'(1x,a12,i4,i10)') ' ',2,basetime(2)
write(*,'(1x,a12,i4,i10)') ' ',3,basetime(3)
write(*,'(1x,a12,i4,i10)') ' ',4,basetime(4)
write(*,'(1x,a12,i4,i10)') ' ',5,basetime(5)
print*
write(*,'(1x,a12,i4,i10)') 'Time range : ',6,basetime(6)
print*
if ( itrigger.ne.0 ) then
print*,'TRIGGER FIELD FOUND IN COLUMN ',itrigger
print*
endif
c Read and decode the selection criterion
fcr = 10
open(fcr,file=inp_criteria)
ncmd=maxcmd
call decode(fcr,cmd,ncmd,vars,ncol,time,ntim,regionf)
close(fcr)
print*
print*,'---- PSEUDO CODE FOR SELECTION --------------------------'
print*
call dumpcode(cmd,ncmd,vars,ncol,time,ntim)
c --------------------------------------------------------------
c Loop over all trajectories - selection
c --------------------------------------------------------------
c Prepare string and parameters for SPECIAL commands
if ( cmd(1).eq.0 ) then
c Get command string
j = 2
len = nint(cmd(j))
specialstr = ''
do k=1,len
j = j + 1
specialstr = trim(specialstr)//char(nint(cmd(j)))
enddo
c Get paramters
j = j + 1
nparam = nint(cmd(j))
do k=1,nparam
j = j + 1
param(k) = cmd(j)
enddo
endif
c Init the counter for selected trajectories
ntraout = 0
c Loop over all trajectories
do i=1,ntrainp
c Copy a single trajectory to <trainp1> and <trigger1>
do j=1,ntim
do k=1,ncol
trainp1(j,k) = trainp(i,j,k)
enddo
trigger1(j) = trigger(i,j)
enddo
C Skip the trajectory if missing data are found for positions
isok = 1
do j=1,ntim
if ( trainp1(j,4).lt.0. ) isok = 0
enddo
c Decide whether the trajectory is selected (handle SPECIAL commands)
if ( isok.eq.1 ) then
if (cmd(1).ne.0 ) then
call select_tra (isok,cmd,ncmd,trainp1,trigger1,ntim,ncol)
else
call special (isok,specialstr,trainp1,ntim,ncol,
> vars,time,param,nparam)
endif
endif
c The trigger might be changed in the selection - copy it
do j=1,ntim
trigger(i,j) = trigger1(j)
enddo
c Set flag for selected trajectories
if (isok.eq.1) then
selflag(i) = 1
ntraout = ntraout + 1
else
selflag(i) = 0
endif
enddo
c --------------------------------------------------------------
c Write output trajectories
c --------------------------------------------------------------
c ------ Write output trajectories -----------------------------
if ( outformat.eq.'trajectory' ) then
c Define the trigger field if it is not yet defined
if ( ( addtrigger.eq.'-trigger' ).and.(itrigger.eq.0) ) then
ncol = ncol + 1
vars(ncol) = 'TRIGGER'
itrigger = ncol
endif
c Allocate memory for output trajectory
allocate(traout(ntraout,ntim,ncol),stat=stat)
if (stat.ne.0) stop '*** error allocating array apply ***'
c Set output trajectories
j = 0
do i=1,ntrainp
if (selflag(i).eq.1) then
j = j + 1
traout(j,1:ntim,1:ncol) = trainp(i,1:ntim,1:ncol)
if ( itrigger.ne.0 ) then
traout(j,1:ntim,itrigger) = real(trigger(i,1:ntim))
endif
endif
enddo
c Write trajectories
call wopen_tra(fod,out_lslfile,ntraout,ntim,ncol,
> basetime,vars,outmode)
call write_tra(fod,traout,ntraout,ntim,ncol,outmode)
call close_tra(fod,outmode)
c ------ Write index list -------------------------------------
elseif ( outformat.eq.'index' ) then
open(10,file=out_lslfile)
do i=1,ntrainp
if ( selflag(i).eq.1) write(10,*) i
enddo
close(10)
c ------ Write boolean list -----------------------------------
elseif ( outformat.eq.'boolean' ) then
open(10,file=out_lslfile)
do i=1,ntrainp
write(10,'(i1)') selflag(i)
enddo
close(10)
c ------ Write count -------------------------------------------
elseif ( outformat.eq.'count' ) then
open(10,file=out_lslfile)
write(10,'(i7)') ntraout
close(10)
c ------ Write starting positions -----------------------------
elseif ( outformat.eq.'startf' ) then
c Allocate memory for output trajectory
allocate(traout(ntraout,1,ncol),stat=stat)
if (stat.ne.0) stop '*** error allocating array apply ***'
c Set output trajectories
j = 0
do i=1,ntrainp
if (selflag(i).eq.1) then
j = j + 1
traout(j,1,:) = trainp(i,1,:)
endif
enddo
c Write trajectories
if (outmode.ne.-1) then
call wopen_tra(fod,out_lslfile,ntraout,1,ncol,
> basetime,vars,outmode)
call write_tra(fod,traout,ntraout,1,ncol,outmode)
call close_tra(fod,outmode)
c Output as a triple list (corresponding to <startf> file)
else
fid = 10
open(fid,file=out_lslfile)
do i=1,ntraout
write(fid,'(3f10.3)') traout(i,1,2), ! longitude
> traout(i,1,3), ! latitude
> traout(i,1,4) ! pressure
enddo
close(fid)
endif
endif
c Write some status information, and end of program message
print*
print*,'---- STATUS INFORMATION --------------------------------'
print*
print*,' # input trajectories : ',ntrainp
print*,' # output trajectories : ',ntraout
print*
print*,' *** END OF PROGRAM SELECT ***'
print*,'========================================================='
stop
c Exception handling
100 stop 'select: First column in input trajectory must be <time>'
101 stop 'select: Input trajectory file is empty'
end
c --------------------------------------------------------------
c Dump the command list
c --------------------------------------------------------------
subroutine dumpcode(out,n,vars,nvars,times,ntimes)
c Write the command list to screen. The command list is decoded
c by call to <decode>
implicit none
c Declaration of subroutine parameters
integer n
real out(n)
integer nvars
character*80 vars(nvars)
integer ntimes
real times(ntimes)
c A single command
character*80 cmd
character*80 var,mode,strtim
integer nval
integer ntim
integer ivar,imode,icmd,itime
c Auxiliary variables
integer i,j
c Loop through the complete list
i=0
100 if (i.lt.n) then
write(*,*) '---------------------------------------'
c Get command
i=i+1
icmd=nint(out(i))
c Special handling of SPECIAL commands
if ( icmd.eq.0 ) then
c Write 'header' for SPECIAL command
write(*,'(i5,f15.4,10x,a10)') i,out(i),'SPECIAL'
c Write command string
i = i + 1
icmd = nint(out(i))
write(*,'(i5,f15.4,10x,a10)') i,out(i),'LEN(CMD)'
do j=1,icmd
i = i + 1
ivar = nint(out(i))
write(*,'(i5,f15.4,10x,a10)') i,out(i),char(ivar)
enddo
c Write parameters
i = i + 1
nval = nint(out(i))
write(*,'(i5,f15.4,10x,a10)') i,out(i),'#PARAMETER'
do j=1,nval
i=i+1
if ( var.ne.'INPOLYGON' ) then
write(*,'(i5,f15.4)') i,out(i)
else
write(*,'(i5,f15.4,a2)') i,out(i),char(nint(out(i)))
endif
enddo
c Nothing else to do - exit
goto 200
endif
c Set the command
if (icmd.eq. 1) cmd='GT'
if (icmd.eq. 2) cmd='LT'
if (icmd.eq. 3) cmd='IN'
if (icmd.eq. 4) cmd='OUT'
if (icmd.eq. 5) cmd='EQ'
if (icmd.eq. 6) cmd='TRUE'
if (icmd.eq. 7) cmd='FALSE'
if (icmd.eq. 8) cmd='ALL'
if (icmd.eq. 9) cmd='ANY'
if (icmd.eq. 10) cmd='NONE'
if (icmd.eq. -1) cmd='BEGIN'
if (icmd.eq. -2) cmd='END'
if (icmd.eq. -3) cmd='AND'
if (icmd.eq. -4) cmd='OR'
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(cmd)
if (icmd.lt.0) goto 100
c Get variable
i=i+1
ivar=nint(out(i))
if ( ivar.eq. -1 ) then
var = 'DIST'
elseif ( ivar.eq. -2 ) then
var = 'DIST0'
elseif ( ivar.eq. -3 ) then
var = 'INPOLYGON'
elseif ( ivar.eq. -4 ) then
var = 'INBOX'
elseif ( ivar.eq. -5 ) then
var = 'INCIRCLE'
elseif ( ivar.eq. -6 ) then
var = 'INREGION'
elseif ( ivar.eq. -7 ) then
var = 'TRIGGER'
elseif ( ivar.eq. -8 ) then
var = 'VERT0'
else
var=vars(ivar)
endif
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(var)
c Get variable mode
i=i+1
imode=nint(out(i))
if (imode.eq.1) mode='VALUE'
if (imode.eq.2) mode='MEAN'
if (imode.eq.3) mode='MAX'
if (imode.eq.4) mode='MIN'
if (imode.eq.5) mode='VAR'
if (imode.eq.6) mode='SUM'
if (imode.eq.7) mode='CHANGE'
if (imode.eq.8) mode='DIFF'
if (imode.eq.9) mode='RANGE'
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(mode)
c Get values
i=i+1
nval=nint(out(i))
write(*,'(i5,f15.4,10x,a10)') i,out(i),'#PARAMETER'
do j=1,nval
i=i+1
if ( var.ne.'INPOLYGON' ) then
write(*,'(i5,f15.4)') i,out(i)
else
write(*,'(i5,f15.4,a2)') i,out(i),char(nint(out(i)))
endif
enddo
c Get the number of times
i=i+1
ntim=nint(out(i))
c the number of times is variable - depending on TRIGGER
if ( ntim .eq. -993 ) then
write(*,'(i5,f15.4,7x,7x,a15)') i,out(i),'TIMES @ TRIGGER'
c Get the detailed list of times
else
write(*,'(i5,f15.4,7x,7x,a6)') i,out(i),'#TIMES'
do j=1,ntim
i=i+1
write(*,'(i5,f15.4,f7.0)') i,out(i),times(nint(out(i)))
enddo
endif
c Get time mode
i=i+1
itime=nint(out(i))
if (itime.eq.1) strtim='ALL'
if (itime.eq.2) strtim='ANY'
if (itime.eq.3) strtim='NONE'
if (itime.lt.0) strtim='TRIGGER'
if ( strtim.ne.'TRIGGER' ) then
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(strtim)
else
write(*,'(i5,f15.4,10x,a10,a3,i3)') i,out(i),trim(strtim),
> ' ->',abs(itime)
endif
goto 100
endif
c Exit point
200 continue
write(*,*) '---------------------------------------'
end
c --------------------------------------------------------------
c Read and decode a selection set
c --------------------------------------------------------------
subroutine decode(fid,out,n,vars,nvars,times,ntimes,regionf)
c A selection file is opened with file id <fid> and transformed
c into a set of commands applied to the trajectories. On input
c <n> sets the maximum dimension of <out>, on output it gives the
c total length of the command string. The output is a list of
c commands with the following format:
c
c out(i) = Command
c out(i+1) = Column index of variable
c out(i+2) = Mode for variable
c out(i+3) = Number of parameters (n)
c out(i+4:i+4+n) = Parameters
c out(i+5+n) = Number of times
c out(i+6+n:i+6+n+m) = List of time indices (m)
c out(i+7+n+m) = Time mode
c
c For SPECIAL commands (to be coded in <special.f>) the format is:
c
c out(i) = Length of command string (n)
c out(i+1:i+n) = Command string
c out(i+n+1) = Number of parameters (m)
c out(i+n+2:i+n+1+m) = List of parameters
c
c The following coding is used
c
c Command Variable mode Time mode
c ---------- ------------- ---------
c GT 1 VALUE 1 ALL 1
c LT 2 MEAN 2 ANY 2
c IN 3 MAX 3 NONE 3
c OUT 4 MIN 4 TRIGGER -i (i the trigger index)
c EQ 5 VAR 5
c BEGIN -1 SUM 6
c END -2 CHANGE 7
c AND -3 DIFF 8
c OR -4 RANGE 9
c TRUE 6
c FALSE 7
c SPECIAL 0
c ALL 8 (TRIGGER)
c ANY 9 (TRIGGER)
c NONE 10 (TRIGGER)
c Several "implicit variables" are supported - out(i+1):
c
c DIST -1 : Path length of the trajectory
c DIST0 -2 : Distance from starting position
c INPOLYGON -3 : Specified polygon region
c INBOX -4 : Longitude/latitude rectangle
c INCIRCLE -5 : Within a specified radius
c INREGION -6 : Within a specified rehion on the region file
c TRIGGER -7 : Trigger field
c VERT0 -8 : Vertical distance from starting position
c
c For the special commands BEGIN, END, AND and OR, only one field
c in <out> is used.
implicit none
c Declaration of subroutine parameters
integer fid
integer n
real out(n)
integer nvars
character*80 vars(nvars)
integer ntimes
real times(ntimes)
character*80 regionf
c Numerical epsilon
real eps
parameter (eps=0.001)
c A single command term
character*80 cmd
character*80 var,mode
integer nval
real val(1000)
integer ntim
real tim(1000)
character*80 tmode
c Specification of a polygon
character*80 filename
integer pn ! Number of entries in lat/lon poly
real latpoly(1000) ! List of polygon latitudes
real lonpoly(1000) ! List of polygon longitudes
real loninpoly,latinpoly ! Lon/lat inside polygon
c Specification of a region
real xcorner(4)
real ycorner(4)
integer iregion
character*80 string
c Transformation to UPN (handling of logical operators)
integer nlogical
integer ilogical(n)
real tmp(n)
integer mlogical
integer isor
c Auxiliary variables
integer i,j
integer j1,j2
integer flag(ntimes)
integer count
integer ok
integer itrigger,ttrigger
c Common block for initialisation of polygon check
real tlonv(1000),vlat_c(1000),vlon_c(1000)
real xlat_c,xlon_c
integer ibndry,nv_c
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
c ------ Decode single commands ---------------------
c Reset the filename for polygons
filename='nil'
c Reset the counter for logical commands
nlogical=0
c Loop through all commands
100 continue
c Read next command (handle special cases)
read(fid,*) cmd
c Special handling of SPECIAL commands
if ( cmd.eq.'SPECIAL' ) then
c Set the flag for SPECIAL command
n = 1
out(n) = 0.
c Read the command string
read(fid,*) var
c Add the command string
n = n + 1
out(n) = len_trim(var)
do j=1,len_trim(var)
n = n + 1
out(n) = ichar(var(j:j))
enddo
c Read the parameters
read(fid,*) nval
read(fid,*) (val(i),i=1,nval)
c Add the parameters
n = n + 1
out(n)=real(nval)
do i=1,nval
n=n+1
out(n)=val(i)
enddo
c Goto exit point - nothing more top do
goto 350
endif
c Handle structure commands
if ( cmd.eq.'BEGIN') then
out(1)=-1.
n=1
nlogical=1
ilogical(1)=n
goto 200
elseif ( cmd.eq.'AND' ) then
n=n+1
out(n)=-3.
nlogical=nlogical+1
ilogical(nlogical)=n
goto 200
elseif ( cmd.eq.'OR' ) then
n=n+1
out(n)=-4.
nlogical=nlogical+1
ilogical(nlogical)=n
goto 200
elseif ( cmd.eq.'END' ) then
n=n+1
out(n)=-2.
nlogical=nlogical+1
ilogical(nlogical)=n
goto 300
endif
c Read other fields associated with the command
read(fid,*) var,mode
c Read parameter
if ( var.eq.'INPOLYGON' ) then
read(fid,*) nval
read(fid,*) filename
filename = trim(filename)
else
read(fid,*) nval
read(fid,*) (val(i),i=1,nval)
endif
c Read times (on request, change to special trigger times)
read(fid,*) ntim
if ( ntim.eq.-993 ) then
ttrigger = 1
ntim = 1
tim(1) = -999.
else
ttrigger = 0
read(fid,*) (tim(i),i=1,ntim)
endif
read(fid,*) tmode
c Bring CAPITAL "TIME,LAT,LON,P" into "time,lat,lon,p"
if (var.eq.'TIME') var='time'
if (var.eq.'LAT' ) var='lat'
if (var.eq.'LON' ) var='lon'
if (var.eq.'P' ) var='p'
c If the time mode is 'TRIGGER', all times of a trajectory
c must be considered
if ( tmode.eq.'TRIGGER' ) then
itrigger = nint(tim(1))
ntim = 1
tim(1) = -999.
endif
c Special times: transform into real time
do i=1,ntim
if ( abs(tim(i)+996.).lt.eps ) tim(i)=times(1)
if ( abs(tim(i)+995.).lt.eps ) tim(i)=times(ntimes)
enddo
c Check whether times are valid
ok=0
do i=1,ntim
if ( (abs(tim(i)+994.).gt.eps).and.
> (abs(tim(i)+999.).gt.eps) )
> then
do j=1,ntimes
if ( abs(tim(i)-times(j)).lt.eps ) then
ok=ok+1
endif
enddo
else
ok=ok+1
endif
enddo
if (ok.ne.ntim) goto 400
c Select all times which are included in the criterion
do i=1,ntimes
flag(i)=0
enddo
i=1
150 if (i.le.ntim) then
c A list of times
if ( (abs(tim(i)+994.).lt.eps) ) then
j1=0
do j=1,ntimes
if ( abs(tim(i-1)-times(j)).lt.eps ) then
j1=j
endif
enddo
j2=0
do j=1,ntimes
if ( abs(tim(i+1)-times(j)).lt.eps ) then
j2=j
endif
enddo
if ( (j1.eq.0).or.(j2.eq.0) ) goto 400
do j=j1,j2
flag(j)=1
enddo
i=i+1
c Explicitly given time value
else
do j=1,ntimes
if ( abs(tim(i)-times(j)).lt.eps ) then
flag(j)=1
endif
enddo
endif
i=i+1
goto 150
endif
c Write command identifier
n=n+1
if (cmd.eq.'GT' ) out(n)= 1.
if (cmd.eq.'LT' ) out(n)= 2.
if (cmd.eq.'IN' ) out(n)= 3.
if (cmd.eq.'OUT' ) out(n)= 4.
if (cmd.eq.'EQ' ) out(n)= 5.
if (cmd.eq.'TRUE' ) out(n)= 6.
if (cmd.eq.'FALSE' ) out(n)= 7.
if (cmd.eq.'ALL ' ) out(n)= 8.
if (cmd.eq.'ANY ' ) out(n)= 9.
if (cmd.eq.'NONE ' ) out(n)=10.
c Write index for variable - force implicit trigger
ok=0
do j=1,nvars
if (vars(j).eq.var) ok=j
enddo
if (var.eq.'TRIGGER') ok = 0
if (ok.eq.0) then
if (var.eq.'DIST') then
ok = -1
elseif (var.eq.'DIST0') then
ok = -2
elseif (var.eq.'INPOLYGON') then
ok = -3
elseif (var.eq.'INBOX') then
ok = -4
elseif (var.eq.'INCIRCLE') then
ok = -5
elseif (var.eq.'INREGION') then
ok = -6
elseif (var.eq.'TRIGGER') then
ok = -7
elseif (var.eq.'VERT0') then
ok = -8
else
goto 400
endif
endif
n=n+1
out(n)=real(ok)
c Write mode for variable
ok=0
if (mode.eq.'VALUE' ) ok=1
if (mode.eq.'MEAN' ) ok=2
if (mode.eq.'MAX' ) ok=3
if (mode.eq.'MIN' ) ok=4
if (mode.eq.'VAR' ) ok=5
if (mode.eq.'SUM' ) ok=6
if (mode.eq.'CHANGE' ) ok=7
if (mode.eq.'DIFF' ) ok=8
if (mode.eq.'RANGE' ) ok=9
if (ok.eq.0) goto 400
n=n+1
out(n)=real(ok)
c Write the parameter values: INPOLYGON
if ( var.eq.'INPOLYGON' ) then
n = n+1
out(n) = len_trim(filename)
do j=1,len_trim(filename)
n = n + 1
out(n) = ichar(filename(j:j))
enddo
c Write parameter value: INREGION
elseif ( var.eq.'INREGION' ) then
iregion = nint(val(1))
open(fid+1,file=regionf)
50 read(fid+1,*,end=51) string
if ( string(1:1).ne.'#' ) then
call regionsplit(string,i,xcorner,ycorner)
if ( i.eq.iregion ) goto 52
endif
goto 50
51 close(fid+1)
print*,' ERROR: region ',iregion,' not found on ',
> trim(regionf)
stop
52 continue
n = n + 1
out(n) = 8 ! Number of parameters
do i=1,4
n = n + 1
out(n) = xcorner(i)
enddo
do i=1,4
n = n + 1
out(n) = ycorner(i)
enddo
c Write parameter values: all other cases
else
n=n+1
out(n)=real(nval)
do i=1,nval
n=n+1
out(n)=val(i)
enddo
endif
c Special time handling: only trigger times are cosidered
if ( ttrigger.eq.1 ) then
n = n+1
out(n)=-993.
c All times are selected
elseif ( abs(tim(1)+999.).lt.eps ) then
n=n+1
out(n)=real(ntimes)
do i=1,ntimes
n=n+1
out(n)=real(i)
enddo
c A selection of times is given
else
count=0
do i=1,ntimes
count=count+flag(i)
enddo
n=n+1
out(n)=real(count)
do i=1,ntimes
if (flag(i).eq.1) then
n=n+1
out(n)=real(i)
endif
enddo
endif
c Write the time mode
if ( tmode.eq.'ALL') then
n=n+1
out(n)=1.
elseif ( tmode.eq.'ANY') then
n=n+1
out(n)=2.
elseif ( tmode.eq.'NONE') then
n=n+1
out(n)=3.
elseif ( tmode.eq.'TRIGGER') then
n=n+1
out(n)=-real(itrigger)
endif
c End loop: handle single command
200 continue
goto 100
c End loop: loop over all commands
300 continue
c ------ Read polygon file, if requested -----------
if ( filename.ne.'nil' ) then
print*
print*,
> '---- POLYGON --------------------------------------------'
print*
print*,'Filename = ',trim(filename)
print*
c Read list of polygon coordinates from file
pn = 0
open(fid+1,file=filename)
read(fid+1,*) loninpoly,latinpoly
print*,'Inside (lon/lat) =',loninpoly,latinpoly
print*
510 continue
pn = pn + 1
read(fid+1,*,end=511) lonpoly(pn),
> latpoly(pn)
print*,pn,lonpoly(pn),latpoly(pn)
goto 510
511 continue
pn = pn - 1
close(fid+1)
c Define the polygon boundaries
call DefSPolyBndry(latpoly,lonpoly,pn,latinpoly,loninpoly)
endif
c ------ Transform to UPN --------------------------
c Check whether logical commands are ok
mlogical=nint(out(ilogical(1)))
if ( mlogical.ne.-1) goto 400
mlogical=nint(out(ilogical(nlogical)))
if ( mlogical.ne.-2) goto 400
c No transformation necessary if only one command
if (nlogical.eq.2) goto 350
c Copy the output to temporary list
do i=1,n
tmp(i)=out(i)
enddo
c Set BEGIN statement
n=1
out(n)=-1.
c Reorder commands and transform to UPN
isor=0
do i=1,nlogical-1
c Get the logical command
mlogical=nint(out(ilogical(i)))
c Connecting OR
if (mlogical.eq.-4) then
if (isor.eq.1) then
n=n+1
out(n)=-4.
else
isor=1
endif
endif
c Put the command onto the stack
do j=ilogical(i)+1,ilogical(i+1)-1
n=n+1
out(n)=tmp(j)
enddo
c Connecting AND operator
if ( mlogical.eq.-3 ) then
n=n+1
out(n)=-3.
endif
enddo
c Set final connecting OR
if (isor.eq.1) then
n=n+1
out(n)=-4.
endif
c Set END statement
n=n+1
out(n)=-2.
c ------ Exit point ---------------------------------
350 continue
return
c ----- Exception handling --------------------------
400 print*,'Invalid selection criterion... Stop'
stop
end
c --------------------------------------------------------------
c Decide whether a trajectory is selected or not
c --------------------------------------------------------------
subroutine select_tra (select,cmd,n,tra,trigger,ntim,ncol)
c Decide whether a single trajectory is selected (<select=1>) or
c is not selected <select=0> according to the selection criterion
c given in <cmd(ncmd)>. The selection criterion <cmd(ncmd)> is
c returned from the call to the subroutine <decode>. The trajectory
c is given in <tra(ntim,ncol)> where <ntim> is the number of times
c and <ncol> is the number of columns.
c
c Important note: the structure of <tra(ntim,ncol)> must match to the
c call parameter <vars,nvars,times,ntimes> in subroutine <decode>.
implicit none
c Declaration of subroutine parameters
integer select
integer n
real cmd(n)
integer ntim,ncol
real tra(ntim,ncol)
integer trigger(ntim)
c Numerical epsilon (for test of equality)
real eps
parameter (eps=0.000001)
c A single command and the associated field
integer icmd,ivar,imode,itime,nsel,nval
integer time(ntim)
real param(100)
real var (ntim)
integer intvar(ntim)
c Boolean values for a single time, a single command and build-up
integer stack(100)
integer nstack
integer istrue(ntim)
integer decision
c Auxiliary variables
integer i,j,k
real tmp,mea
integer istack1,istack2
real lat0,lon0,lat1,lon1
real length(ntim)
integer flag
real dist
real xcorner(4),ycorner(4)
integer iparam
character ch
real varmin,varmax
real lev0,lev1
c Common block for initialisation of polygon check
real tlonv(1000),vlat_c(1000),vlon_c(1000)
real xlat_c,xlon_c
integer ibndry,nv_c
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
c Externals
real sdis ! Spherical distance
external sdis
integer inregion ! Boolean flag for regions
external inregion
c Reset the decision stack (with locical values)
nstack=0
c Loop through the complete command list
i=0
100 if (i.lt.n) then
c --- Get the command -------------------------------
i=i+1
icmd=nint(cmd(i))
c --- Handle structural commands (BEGIN, END, AND, OR)
c Handle BEGIN statement
if ( icmd.eq.-1) then
nstack=0
goto 200
endif
c Handle END statement
if (icmd.eq.-2) then
goto 300
endif
c Handle AND statement
if (icmd.eq.-3) then
istack1=stack(nstack)
nstack=nstack-1
istack2=stack(nstack)
if ((istack1.eq.1).and.(istack2.eq.1)) then
stack(nstack)=1
else
stack(nstack)=0
endif
goto 200
endif
c Handle OR statement
if (icmd.eq.-4) then
istack1=stack(nstack)
nstack=nstack-1
istack2=stack(nstack)
if ((istack1.eq.1).or.(istack2.eq.1)) then
stack(nstack)=1
else
stack(nstack)=0
endif
goto 200
endif
c --- Get all command details (parameters, modes, times)
c Get variable (<ivar> gets the column index in <tra>)
i=i+1
ivar=nint(cmd(i))
c Get variable mode
i=i+1
imode=nint(cmd(i))
c Get parameter values
i=i+1
nval=nint(cmd(i))
do j=1,nval
i=i+1
param(j)=cmd(i)
enddo
c Get times (<time(j)> gets the row indices of <tra>)
i=i+1
nsel=nint(cmd(i))
if ( nsel .eq. -993 ) then
nsel = 0
do k=1,ntim
if ( trigger(k).ne.0 ) then
nsel = nsel + 1
time(nsel) = k
endif
enddo
else
do j=1,nsel
i=i+1
time(j)=nint(cmd(i))
enddo
endif
c If no times are selected, exit with non-select status
if ( nsel.eq.0 ) then
stack(1) = 0
goto 300
endif
c Get time mode
i=i+1
itime=nint(cmd(i))
c --- Prepare field values for analysis -----------
c Implicit variable: DIST
if ( ivar.eq. -1 ) then
length(1) = 0.
do j=2,ntim
lon0 = tra(j-1,2)
lat0 = tra(j-1,3)
lon1 = tra(j ,2)
lat1 = tra(j ,3)
length(j) = length(j-1) + sdis(lon0,lat0,lon1,lat1)
enddo
do j=1,nsel
var(j) = length( time(j) )
enddo
c Implict variable: DIST0
elseif ( ivar.eq. -2 ) then
do j=1,nsel
lon0 = tra(1 ,2)
lat0 = tra(1 ,3)
lon1 = tra(time(j),2)
lat1 = tra(time(j),3)
var(j) = sdis(lon0,lat0,lon1,lat1)
enddo
c Implict variable: INPOLYGON
elseif ( ivar.eq. -3 ) then
do j=1,nsel
lon1 = tra(time(j),2)
lat1 = tra(time(j),3)
call LctPtRelBndry(lat1,lon1,flag)
if ( (flag.eq.1).or.(flag.eq.2) ) then
var(j) = 1.
else
var(j) = 0.
endif
enddo
c Implict variable: INBOX
elseif ( ivar.eq. -4 ) then
do j=1,nsel
lon1 = tra(time(j),2)
lat1 = tra(time(j),3)
if ( ( lon1.ge.param(1) ).and. ! lonmin
> ( lon1.le.param(2) ).and. ! lonmax
> ( lat1.ge.param(3) ).and. ! latmin
> ( lat1.le.param(4) ) ) ! latmax
> then
var(j) = 1
else
var(j) = 0
endif
enddo
c Implict variable: INCIRCLE (lonc=param(1),latc=param(2),radius=param(3))
elseif ( ivar.eq. -5 ) then
do j=1,nsel
lon1 = tra(time(j),2)
lat1 = tra(time(j),3)
dist = sdis( lon1,lat1,param(1),param(2) )
if ( dist.le.param(3) ) then
var(j) = 1
else
var(j) = 0
endif
enddo
c Implict variable: INREGION (xcorner=param(1..4),ycorner=param(5..8) )
elseif ( ivar.eq.-6 ) then
do j=1,4
xcorner(j) = param(j )
ycorner(j) = param(j+4)
enddo
do j=1,nsel
lon1 = tra(time(j),2)
lat1 = tra(time(j),3)
var(j) = inregion (lon1,lat1,xcorner,ycorner)
enddo
c Implict variable: TRIGGER
elseif ( ivar.eq. -7 ) then
do j=1,nsel
intvar(j) = trigger( time(j) )
enddo
c Implicit variable: VERT0
elseif ( ivar.eq. -8 ) then
do j=1,nsel
lev0 = tra(1 ,4)
lev1 = tra(time(j),4)
var(j) = lev0 - lev1
enddo
c Explicit variable (column index <ivar>)
else
do j=1,nsel
var(j) = tra(time(j),ivar)
enddo
endif
c Take MEAN of the variable (mean of selected times)
if (imode.eq.2) then
tmp=0.
do j=1,nsel
tmp=tmp+var(j)
enddo
var(1)=tmp/real(nsel)
nsel=1
c Take MAX of the variable (maximum of selected times)
elseif (imode.eq.3) then
tmp=var(1)
do j=2,nsel
if (var(j).gt.tmp) tmp=var(j)
enddo
var(1)=tmp
nsel=1
c Take MIN of the variable (minimum of selected times)
elseif (imode.eq.4) then
tmp=var(1)
do j=2,nsel
if (var(j).lt.tmp) tmp=var(j)
enddo
var(1)=tmp
nsel=1
c Take VAR of the variable (variance over all selected times)
elseif (imode.eq.5) then
tmp=0.
do j=1,nsel
tmp=tmp+var(j)
enddo
mea=tmp/real(nsel)
do j=1,nsel
tmp=tmp+(var(j)-mea)**2
enddo
var(1)=1./real(nsel-1)*tmp
nsel=1
c Take SUM of the variable (sum over all selected times)
elseif (imode.eq.6) then
tmp=0.
do j=1,nsel
tmp=tmp+var(j)
enddo
var(1)=tmp
nsel=1
c Take CHANGE of the variable (absolute difference between first and last time)
elseif (imode.eq.7) then
var(1)=abs(var(1)-var(nsel))
nsel=1
c Take DIFF of the variable (first minus last time)
elseif (imode.eq.8) then
var(1)=var(1)-var(nsel)
nsel=1
c Take RANGE of the variable
elseif (imode.eq.9) then
varmax=var(1)
varmin=var(1)
do j=2,nsel
if (var(j).gt.varmax) varmax=var(j)
if (var(j).lt.varmin) varmin=var(j)
enddo
var(1) = varmax - varmin
nsel=1
endif
c --- Apply the operators to the single values ---
do j=1,nsel
c GT
if (icmd.eq.1) then
if (var(j).gt.param(1)) then
istrue(j)=1
else
istrue(j)=0
endif
c LT
elseif (icmd.eq.2) then
if (var(j).lt.param(1)) then
istrue(j)=1
else
istrue(j)=0
endif
c IN
elseif (icmd.eq.3) then
if ( (var(j).gt.param(1)).and.
> (var(j).lt.param(2)) )
> then
istrue(j)=1
else
istrue(j)=0
endif
c OUT
elseif (icmd.eq.4) then
if ( (var(j).lt.param(1)).or.
> (var(j).gt.param(2)) )
> then
istrue(j)=1
else
istrue(j)=0
endif
c EQ
elseif (icmd.eq.5) then
if (abs(var(j)-param(1)).lt.eps) then
istrue(j)=1
else
istrue(j)=0
endif
c TRUE
elseif (icmd.eq.6) then
if (abs(var(j)).lt.eps) then
istrue(j)=0
else
istrue(j)=1
endif
c FALSE
elseif (icmd.eq.7) then
if (abs(var(j)).lt.eps) then
istrue(j)=1
else
istrue(j)=0
endif
c ALL
elseif (icmd.eq.8) then
istrue(j) = 1
do k=1,nval
iparam = nint(param(k))-1
if (btest(intvar(j),iparam).eqv..false.) then
istrue(j) = 0
endif
enddo
c ANY
elseif (icmd.eq.9) then
istrue(j) = 0
do k=1,nval
iparam = nint(param(k))-1
if (btest(intvar(j),iparam).eqv..true.) then
istrue(j) = 1
endif
enddo
c NONE
elseif (icmd.eq.10) then
istrue(j) = 1
do k=1,nval
iparam = nint(param(k))-1
if (btest(intvar(j),iparam).eqv..true.) then
istrue(j) = 0
endif
enddo
endif
enddo
c --- Determine the overall boolean value ----------
c ALL
if (itime.eq.1) then
decision=1
do j=1,nsel
if (istrue(j).eq.0) then
decision=0
goto 110
endif
enddo
110 continue
c ANY
elseif (itime.eq.2) then
decision=0
do j=1,nsel
if (istrue(j).eq.1) then
decision=1
goto 120
endif
enddo
120 continue
c NONE
elseif (itime.eq.3) then
decision=1
do j=1,nsel
if (istrue(j).eq.1) then
decision=0
goto 130
endif
enddo
130 continue
c TRIGGER
elseif (itime.lt.0) then
decision=1
do j=1,nsel
if (istrue(j).eq.1) then
trigger(j) = ior( trigger(j), 2**(abs(itime)-1) )
endif
enddo
endif
c --- Put the new boolean value onto the stack
nstack=nstack+1
stack(nstack)=decision
c Exit point for loop
200 continue
goto 100
endif
c Return the decision (selected or non-selected)
300 continue
select=stack(1)
end
c --------------------------------------------------------------------------
c Split a region string and get corners of the domain
c --------------------------------------------------------------------------
subroutine regionsplit(string,iregion,xcorner,ycorner)
c The region string comes either as <lonw,lone,lats,latn> or as <lon1,lat1,
c lon2,lat2,lon3,lat3,lon4,lat4>: split it into ints components and get the
c four coordinates for the region
implicit none
c Declaration of subroutine parameters
character*80 string
real xcorner(4),ycorner(4)
integer iregion
c Local variables
integer i,n
integer il,ir
real subfloat (80)
integer stat
integer len
c ------- Split the string
i = 1
n = 0
stat = 0
il = 1
len = len_trim(string)
100 continue
c Find start of a substring
do while ( stat.eq.0 )
if ( string(i:i).ne.' ' ) then
stat = 1
il = i
else
i = i + 1
endif
enddo
c Find end of substring
do while ( stat.eq.1 )
if ( ( string(i:i).eq.' ' ) .or. ( i.eq.len ) ) then
stat = 2
ir = i
else
i = i + 1
endif
enddo
c Convert the substring into a number
if ( stat.eq.2 ) then
n = n + 1
read(string(il:ir),*) subfloat(n)
stat = 0
endif
if ( i.lt.len ) goto 100
c -------- Get the region number
iregion = nint(subfloat(1))
c -------- Get the corners of the region
if ( n.eq.5 ) then ! lonw(2),lone(3),lats(4),latn(5)
xcorner(1) = subfloat(2)
ycorner(1) = subfloat(4)
xcorner(2) = subfloat(3)
ycorner(2) = subfloat(4)
xcorner(3) = subfloat(3)
ycorner(3) = subfloat(5)
xcorner(4) = subfloat(2)
ycorner(4) = subfloat(5)
elseif ( n.eq.9 ) then ! lon1,lat1,lon2,lat2,lon3,lon4,lat4
xcorner(1) = subfloat(2)
ycorner(1) = subfloat(3)
xcorner(2) = subfloat(4)
ycorner(2) = subfloat(5)
xcorner(3) = subfloat(6)
ycorner(3) = subfloat(7)
xcorner(4) = subfloat(8)
ycorner(4) = subfloat(9)
else
print*,' ERROR: invalid region specification '
print*,' ',trim(string)
stop
endif
end
c --------------------------------------------------------------------------
c Decide whether lat/lon point is in or out of region
c --------------------------------------------------------------------------
integer function inregion (lon,lat,xcorner,ycorner)
c Decide whether point (lon/lat) is in the region specified by <xcorner(1..4),
c ycorner(1..4).
implicit none
c Declaration of subroutine parameters
real lon,lat
real xcorner(4),ycorner(4)
c Local variables
integer flag
real xmin,xmax,ymin,ymax
integer i
c Reset the flag
flag = 0
c Set some boundaries
xmax = xcorner(1)
xmin = xcorner(1)
ymax = ycorner(1)
ymin = ycorner(1)
do i=2,4
if (xcorner(i).lt.xmin) xmin = xcorner(i)
if (xcorner(i).gt.xmax) xmax = xcorner(i)
if (ycorner(i).lt.ymin) ymin = ycorner(i)
if (ycorner(i).gt.ymax) ymax = ycorner(i)
enddo
c Do the tests - set flag=1 if all tests pased
if (lon.lt.xmin) goto 970
if (lon.gt.xmax) goto 970
if (lat.lt.ymin) goto 970
if (lat.gt.ymax) goto 970
if ((lon-xcorner(1))*(ycorner(2)-ycorner(1))-
> (lat-ycorner(1))*(xcorner(2)-xcorner(1)).gt.0.) goto 970
if ((lon-xcorner(2))*(ycorner(3)-ycorner(2))-
> (lat-ycorner(2))*(xcorner(3)-xcorner(2)).gt.0.) goto 970
if ((lon-xcorner(3))*(ycorner(4)-ycorner(3))-
> (lat-ycorner(3))*(xcorner(4)-xcorner(3)).gt.0.) goto 970
if ((lon-xcorner(4))*(ycorner(1)-ycorner(4))-
> (lat-ycorner(4))*(xcorner(1)-xcorner(4)).gt.0.) goto 970
flag = 1
c Return the value
970 continue
inregion = flag
return
end
c --------------------------------------------------------------------------
c Spherical distance between lat/lon points
c --------------------------------------------------------------------------
real function sdis(xp,yp,xq,yq)
c
c calculates spherical distance (in km) between two points given
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
c
real re
parameter (re=6370.)
real pi180
parameter (pi180=3.14159/180.)
real xp,yp,xq,yq,arg
arg=sin(pi180*yp)*sin(pi180*yq)+
> cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
if (arg.lt.-1.) arg=-1.
if (arg.gt.1.) arg=1.
sdis=re*acos(arg)
end
c ****************************************************************
c * Given some spherical polygon S and some point X known to be *
c * located inside S, these routines will determine if an arbit- *
c * -rary point P lies inside S, outside S, or on its boundary. *
c * The calling program must first call DefSPolyBndry to define *
c * the boundary of S and the point X. Any subsequent call to *
c * subroutine LctPtRelBndry will determine if some point P lies *
c * inside or outside S, or on its boundary. (Usually *
c * DefSPolyBndry is called once, then LctPrRelBndry is called *
c * many times). *
c * *
c * REFERENCE: Bevis, M. and Chatelain, J.-L. (1989) *
c * Maflaematical Geology, vol 21. *
c * VERSION 1.0 *
c ****************************************************************
Subroutine DefSPolyBndry(vlat,vlon,nv,xlat, xlon)
c ****************************************************************
c * This mmn entry point is used m define ~e spheric~ polygon S *
c * and the point X. *
c * ARGUMENTS: *
c * vlat,vlon (sent) ... vectors containing the latitude and *
c * longitude of each vertex of the *
c * spherical polygon S. The ith.vertex is *
c * located at [vlat(i),vlon(i)]. *
c * nv (sent) ... the number of vertices and sides in the *
c * spherical polygon S *
c * xlat,xlon (sent) ... latitude and longitude of some point X *
c * located inside S. X must not be located *
c * on any great circle that includes two *
c * vertices of S. *
c * *
c * UNITS AND SIGN CONVENTION: *
c * Latitudes and longitudes are specified in degrees. *
c * Latitudes are positive to the north and negative to the *
c * south. *
c * Longitudes are positive to the east and negative to the *
c * west. *
c * *
c * VERTEX ENUMERATION: *
c * The vertices of S should be numbered sequentially around the *
c * border of the spherical polygon. Vertex 1 lies between vertex*
c * nv and vertex 2. Neighbouring vertices must be seperated by *
c * less than 180 degrees. (In order to generate a polygon side *
c * whose arc length equals or exceeds 180 degrees simply *
c * introduce an additional (pseudo)vertex). Having chosen *
c * vertex 1, the user may number the remaining vertices in *
c * either direction. However if the user wishes to use the *
c * subroutine SPA to determine the area of the polygon S (Bevis *
c * & Cambareri, 1987, Math. Geol., v.19, p. 335-346) then he or *
c * she must follow the convention whereby in moving around the *
c * polygon border in the direction of increasing vertex number *
c * clockwise bends occur at salient vertices. A vertex is *
c * salient if the interior angle is less than 180 degrees. *
c * (In the case of a convex polygon this convention implies *
c * that vertices are numbered in clockwise sequence). *
c ****************************************************************
implicit none
integer mxnv,nv
c ----------------------------------------------------------------
c Edit next statement to increase maximum number of vertices that
c may be used to define the spherical polygon S
c The value of parameter mxnv in subroutine LctPtRelBndry must match
c that of parameter mxnv in this subroutine, as assigned above.
c ----------------------------------------------------------------
parameter (mxnv=2000)
real vlat(nv),vlon(nv),xlat,xlon,dellon
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
integer i,ibndry,nv_c,ip
data ibndry/0/
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
if (nv.gt.mxnv) then
print *,'nv exceeds maximum allowed value'
print *,'adjust parameter mxnv in subroutine DefSPolyBndry'
stop
endif
ibndry=1 ! boundary defined at least once (flag)
nv_c=nv ! copy for named common
xlat_c=xlat ! . . . .
xlon_c=xlon !
do i=1,nv
vlat_c(i)=vlat(i) ! "
vlon_c(i)=vlon(i) !
call TrnsfmLon(xlat,xlon,vlat(i),vlon(i),tlonv(i))
if (i.gt.1) then
ip=i-1
else
ip=nv
endif
if ((vlat(i).eq.vlat(ip)).and.(vlon(i).eq.vlon(ip))) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' and ',ip,' are not distinct'
print*,'lat ',i,ip,vlat(i),vlat(ip)
print*,'lon ',i,ip,vlon(i),vlon(ip)
stop
endif
if (tlonv(i).eq.tlonv(ip)) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' & ',ip,' on same gt. circle as X'
stop
endif
if (vlat(i).eq.(-vlat(ip))) then
dellon=vlon(i)-vlon(ip)
if (dellon.gt.+180.) dellon=dellon-360.
if (dellon.lt.-180.) dellon=dellon-360.
if ((dellon.eq.+180.0).or.(dellon.eq.-180.0)) then
print *,'DefSPolyBndry detects user error:'
print *,'vertices ',i,' and ',ip,' are antipodal'
stop
endif
endif
enddo
return
end
c ****************************************************************
Subroutine LctPtRelBndry(plat,plon,location)
c ****************************************************************
c ****************************************************************
c * This routine is used to see if some point P is located *
c * inside, outside or on the boundary of the spherical polygon *
c * S previously defined by a call to subroutine DefSPolyBndry. *
c * There is a single restriction on point P: it must not be *
c * antipodal to the point X defined in the call to DefSPolyBndry*
c * (ie.P and X cannot be seperated by exactly 180 degrees). *
c * ARGUMENTS: *
c * plat,plon (sent)... the latitude and longitude of point P *
c * location (returned)... specifies the location of P: *
c * location=0 implies P is outside of S *
c * location=1 implies P is inside of S *
c * location=2 implies P on boundary of S *
c * location=3 implies user error (P is *
c * antipodal to X) *
c * UNFfS AND SIGN CONVENTION: *
c * Latitudes and longitudes are specified in degrees. *
c * Latitudes are positive to the north and negative to the *
c * south. *
c * Longitudes are positive to the east and negative to the *
c * west. *
c ****************************************************************
implicit none
integer mxnv
c ----------------------------------------------------------------
c The statement below must match that in subroutine DefSPolyBndry
c ----------------------------------------------------------------
parameter (mxnv=2000)
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
real plat,plon,vAlat,vAlon,vBlat,vBlon,tlonA,tlonB,tlonP
real tlon_X,tlon_P,tlon_B,dellon
integer i,ibndry,nv_c,location,icross,ibrngAB,ibrngAP,ibrngPB
integer ibrng_BX,ibrng_BP,istrike
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
if (ibndry.eq.0) then ! user has never defined the bndry
print*,'Subroutine LctPtRelBndry detects user error:'
print*,'Subroutine DefSPolyBndry must be called before'
print*,'subroutine LctPtRelBndry can be called'
stop
endif
if (plat.eq.(-xlat_c)) then
dellon=plon-xlon_c
if (dellon.lt.(-180.)) dellon=dellon+360.
if (dellon.gt.+180.) dellon=dellon-360.
if ((dellon.eq.+180.0).or.(dellon.eq.-180.)) then
print*,'Warning: LctPtRelBndry detects case P antipodal
> to X'
print*,'location of P relative to S is undetermined'
location=3
return
endif
endif
location=0 ! default ( P is outside S)
icross=0 ! initialize counter
if ((plat.eq.xlat_c).and.(plon.eq.xlon_c)) then
location=1
return
endif
call TrnsfmLon (xlat_c,xlon_c,plat,plon,tlonP)
do i=1,nv_c ! start of loop over sides of S
vAlat=vlat_c(i)
vAlon=vlon_c(i)
tlonA=tlonv(i)
if (i.lt.nv_c) then
vBlat=vlat_c(i+1)
vBlon=vlon_c(i+1)
tlonB=tlonv(i+1)
else
vBlat=vlat_c(1)
vBlon=vlon_c(1)
tlonB=tlonv(1)
endif
istrike=0
if (tlonP.eq.tlonA) then
istrike=1
else
call EastOrWest(tlonA,tlonB,ibrngAB)
call EastOrWest(tlonA,tlonP,ibrngAP)
call EastOrWest(tlonP,tlonB,ibrngPB)
if((ibrngAP.eq.ibrngAB).and.(ibrngPB.eq.ibrngAB)) istrike=1
endif
if (istrike.eq.1) then
if ((plat.eq.vAlat).and.(plon.eq.vAlon)) then
location=2 ! P lies on a vertex of S
return
endif
call TrnsfmLon(vAlat,vAlon,xlat_c,xlon_c,tlon_X)
call TrnsfmLon(vAlat,vAlon,vBlat,vBlon,tlon_B)
call TrnsfmLon(vAlat,vAlon,plat,plon,tlon_P)
if (tlon_P.eq.tlon_B) then
location=2 ! P lies on side of S
return
else
call EastOrWest(tlon_B,tlon_X,ibrng_BX)
call EastOrWest(tlon_B,tlon_P,ibrng_BP)
if(ibrng_BX.eq.(-ibrng_BP)) icross=icross+1
endif
endif
enddo ! end of loop over the sides of S
c if the arc XP crosses the boundary S an even number of times then P
c is in S
if (mod(icross,2).eq.0) location=1
return
end
c ****************************************************************
subroutine TrnsfmLon(plat,plon,qlat,qlon,tranlon)
c ****************************************************************
c * This subroutine is required by subroutines DefSPolyBndry & *
c * LctPtRelBndry. It finds the 'longitude' of point Q in a *
c * geographic coordinate system for which point P acts as a *
c * 'north pole'. SENT: plat,plon,qlat,qlon, in degrees. *
c * RETURNED: tranlon, in degrees. *
c ****************************************************************
implicit none
real pi,dtr,plat,plon,qlat,qlon,tranlon,t,b
parameter (pi=3.141592654,dtr=pi/180.0)
if (plat.eq.90.) then
tranlon=qlon
else
t=sin((qlon-plon)*dtr)*cos(qlat*dtr)
b=sin(dtr*qlat)*cos(plat*dtr)-cos(qlat*dtr)*sin(plat*dtr)
> *cos((qlon-plon)*dtr)
tranlon=atan2(t,b)/dtr
endif
return
end
c ****************************************************************
subroutine EastOrWest(clon,dlon,ibrng)
c ****************************************************************
c * This subroutine is required by subroutine LctPtRelBndry. *
c * This routine determines if in travelling the shortest path *
c * from point C (at longitude clon) to point D (at longitude *
c * dlon) one is heading east, west or neither. *
c * SENT: clon,dlon; in degrees. RETURNED: ibrng *
c * (1=east,-1=west, 0=neither). *
c ****************************************************************
implicit none
real clon,dlon,del
integer ibrng
del=dlon-clon
if (del.gt.180.) del=del-360.
if (del.lt.-180.) del=del+360.
if ((del.gt.0.0).and.(del.ne.180.)) then
ibrng=-1 ! (D is west of C)
elseif ((del.lt.0.0).and.(del.ne.-180.)) then
ibrng=+1 ! (D is east of C)
else
ibrng=0 ! (D north or south of C)
endif
return
end

/tags/1.0/select/select.make
0,0 → 1,11
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = special.o select.o ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
.f.o: $*.f
${F77} -c ${FFLAGS} ${INCS} $*.f
select: $(OBJS)
${F77} -o select $(OBJS) ${INCS} $(LIBS)

/tags/1.0/select/select.perl
0,0 → 1,220
#!/usr/bin/perl
# --------------------------------------------------------
# Separate different commands out (delimiter & and |)
# --------------------------------------------------------
# Get input command and remove all spaces
$cmd = $ARGV[0];
$_ = $cmd;s/\s+//g;$cmd=$_;
$len = length $cmd;
# Split the command string according to logical operators
$nline = 0;
while ( $len > 0 )
{
# Get the length of the (remaining) command string
$len = length $cmd;
# Get the position of the next command separator
$and = index($cmd,'&');
$or = index($cmd,'|' );
if ( ($and == -1) && ($or == -1) )
{ $next = $len+1; }
elsif ( ($and == -1) && ($or >= 0) )
{ $next = $or; @logop[$nline] = 'OR'; }
elsif ( ($and >= 0) && ($or == -1) )
{ $next = $and; @logop[$nline] = 'AND'; }
elsif ($and > $or)
{ $next = $or; @logop[$nline] = 'OR'; }
else
{ $next = $and; @logop[$nline] = 'AND'; }
# A logical operator is not allowed to be at position 0
if ( $next == 0)
{
die('Invalid expression... Check logical operators & and |');
}
# Extract the next substring
$sub = substr($cmd,0,$next);
$cmd = substr($cmd,$next+1,$len-$next-1);
$len = length $cmd;
# Save the command in a new line
@field[$nline] = $sub;
$nline = $nline + 1;
}
# --------------------------------------------------------
# Handle each command line separately
# --------------------------------------------------------
# Write start marker
print "BEGIN \n";
foreach ( $i = 0; $i < $nline; $i++ )
{
# Split the command into its four components
@entry = split /:/, @field[$i];
$nentry = @entry;
# Either four or three elements are needed
if ( ($nentry < 3) | ($nentry > 4) )
{
die('Each expression needs either 3 or 4 fields...');
}
# Write the command
print "@entry[0] \n";
# Get the variable and the 'mode' for this variable
$left = index(@entry[1],'(');
$right = index(@entry[1],')');
if ( ($left == -1) && ($right == -1) )
{
$var = @entry[1];
$mode = 'VALUE';
}
elsif ( ($left > 0) && ($right > $left) )
{
$var = substr(@entry[1],0,$left);
$mode = substr(@entry[1],$left+1,$right-$left-1);
}
else
{
die('Invalid variable specification...');
}
print "$var $mode \n";
# Get the parameter list for this command
@param = split /,/, @entry[2];
$nparam = @param;
print "$nparam \n";
print "@param \n";
# If only three parameters are given, the time is assumed to be the first one
if ( $nentry == 3 )
{
@entry[3]='FIRST';
}
# Get the variable and the 'mode' for this variable
$left = index(@entry[3],'(');
$right = index(@entry[3],')');
if ( ($left == -1) && ($right == -1) )
{
$time = @entry[3];
$mode = 'ALL';
}
elsif ( ($left > 0) && ($right > $left) )
{
$time = substr(@entry[3],0,$left);
$mode = substr(@entry[3],$left+1,$right-$left-1);
}
else
{
die('Invalid time specification...');
}
# Get the time list for this command
if ( $time eq 'ALL' )
{
$time = -999;
print "1 \n";
print "$time \n";
}
elsif ( $time eq 'FIRST' )
{
$time = -996;
print "1 \n";
print "$time \n";
}
elsif ( $time eq 'LAST' )
{
$time = -995;
print "1 \n";
print "$time \n";
}
elsif ( $time eq 'TRIGGER' )
{
print "-993 \n";
}
else
{
@times = split /,/, $time;
$outstr = "";
$outlen = 0;
foreach $j ( @times )
{
$to = index($j,'to');
if ( $to == -1 )
{
if ( $j eq 'FIRST' )
{
$outlen=$outlen+1;
$outstr=$outstr . " -996 ";
}
elsif ( $j eq 'LAST' )
{
$outlen=$outlen+1;
$outstr=$outstr . " -995 ";
}
else
{
$outlen=$outlen+1;
$outstr=$outstr . "$j ";
}
}
else
{
$outlen = $outlen+3;
$t1 = substr($j,0,$to);
$t2 = substr($j,$to+2,length($j)-$to+1);
if ( $t1 eq 'FIRST' )
{ $t1='-996'; };
if ( $t2 eq 'FIRST' )
{ $t2='-996'; };
if ( $t1 eq 'LAST' )
{ $t1='-995'; };
if ( $t2 eq 'LAST' )
{ $t2='-995'; };
$outstr=$outstr . $t1 . " -994 " . $t2 . " ";
}
}
print "$outlen \n";
print "$outstr \n";
}
# Write the time mode
if ( $mode eq 'ALL' )
{
print "$mode \n";
}
elsif ( $mode eq 'ANY' )
{
print "$mode \n";
}
elsif ( $mode eq 'NONE' )
{
print "$mode \n";
}
elsif ( $mode eq 'TRIGGER' )
{
print "$mode \n";
}
else
{
die('Invalid time mode...');
}
# Write the logical operator
if ( $i < $nline-1 )
{
print "@logop[$i] \n";
}
}
# Write end marker
print "END \n";
Property changes:
Added: svn:executable

/tags/1.0/select/select.sh
0,0 → 1,188
#!/bin/csh
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Set some parameters
set crifile=${PWD}/select.parsed
# Set base directories (run+prog)
set cdfdir=${PWD}
set tradir=${PWD}
# Write usage information
if ( ${#argv} == 0 ) then
echo
${LAGRANTO}/bin/lagrantohelp select short
echo
exit 0
endif
# Write list of special selection criteria
if ( "$1" == "-special" ) then
grep '%)' ${LAGRANTO}/select/special.f
exit 0
endif
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR SELECT *** '
echo
# Save input arguments
set inpfile=$1
set outfile=$2
set crit="$3"
shift
shift
shift
# Handle optional arguments
echo
echo '---- OPTIONAL FLAGS -------------------------------------'
echo
set noclean = 'false'
set format = 'trajectory'
set regionf = 'regionf'
set trigger = 'nil'
while ( $#argv > 0 )
switch ( $argv[1] )
case -noclean
set noclean = 'true'
echo "noclean -> true (user defined)"
breaksw
case -trigger
set trigger = '-trigger'
echo "trigger -> true (user defined)"
breaksw
case -boolean
set format = 'boolean'
echo "format -> boolean (user defined)"
breaksw
case -index
set format = 'index'
echo "format -> index (user defined)"
breaksw
case -count
set format = 'count'
echo "format -> count (user defined)"
breaksw
case -startf
set format = 'startf'
echo "format -> startf (user defined)"
breaksw
case -regionf
set regionf = $argv[2]
echo "regionf -> ${regionf} (user defined)"
shift;
breaksw
endsw
shift;
end
# Decide whether <select> is a file or an explicit criterion
set flag_select = 'criterion'
set test = `echo ${crit} | grep ':' | wc -c`
if ( "${test}" == "0" ) then
set flag_select = 'file'
set flag_selectfile = $crit
if ( -f ${flag_selectfile} ) then
set crit = `cat ${flag_selectfile}`
else
echo " ERROR: criterion file ${flag_selectfile} is missing... Stop"
exit 1
endif
endif
# Get the start, end and reference date for the tracing
set ntra = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntra`
set ntim = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntim`
set ncol = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ncol`
set times = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} times`
set vars = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} vars`
# Split the criterion into subunits (with Perl)
${LAGRANTO}/select/select.perl "${crit}" >! ${crifile}
if ( "${status}" != "0" ) then
echo "ERROR: Parser <select> failed"
exit 1
endif
# Write some status information
echo
echo '---- DIRECTORIES AND PROGRAMS ---------------------------'
echo
echo "CDF directory : ${cdfdir}"
echo "TRA directory : ${tradir}"
echo "PROGRAM SELECT : ${LAGRANTO}/select/select"
echo "PARSER : ${LAGRANTO}/select/select.perl"
echo "CRITERION FILE : ${crifile}"
echo
echo '---- INPUT PARAMETERS -----------------------------------'
echo
echo "Input file : ${inpfile}"
echo "Output file : ${outfile}"
echo "Output format : ${format}"
if ( "${flag_select}" == "criterion" ) then
echo "Criterion : ${crit}"
else
echo "Criterion : ${crit} (from file ${flag_selectfile})"
endif
echo
echo '---- INPUT FILE -----------------------------------------'
echo
echo "# TRA : ${ntra}"
echo "# TIMES : ${ntim}"
echo "# COLUMNS : ${ncol}"
echo "Times : ${times}"
echo "Variables : ${vars}"
echo
echo '---- PARSED CRITERION ------------------------------------'
echo
cat ${crifile}
# Finish the preprocessor
echo
echo ' *** END OF PREPROCESSOR SELECT *** '
echo '========================================================='
echo
# Run the selection programme
echo \"${inpfile}\" >! select.param
echo \"${outfile}\" >> select.param
echo \"${format}\" >> select.param
echo \"${crifile}\" >> select.param
echo ${ntra} >> select.param
echo ${ntim} >> select.param
echo ${ncol} >> select.param
echo \"${regionf}\" >> select.param
echo \"${trigger}\" >> select.param
${LAGRANTO}/select/select
if ( "${status}" != "0" ) then
echo "ERROR: Program <select> failed"
exit 1
endif
# Make clean
if ( "${noclean}" == "false" ) then
\rm -f select.param
\rm -f ${crifile}
endif
exit 0
Property changes:
Added: svn:executable

/tags/1.0/select/special.f
0,0 → 1,80
SUBROUTINE special (flag,cmd,tra,ntim,ncol,
> vars,times,param,nparam)
c ***************************************************************************
c * *
c * OUTPUT: flag -> 1 if trajectory is selected, 0 if not *
c * *
c * INPUT: cmd <- command string *
c * tra(ntim,ncol) <- single trajectory: indices time,column *
c * ntim <- number of times *
c * ncol <- number of columns (including time,lon,lat,p) *
c * vars(ncol) <- names of columns *
c * times(ntim) <- List of times
c * param(nparam) <- parameter values *
c * nparam <- number of parameters *
c * *
c ***************************************************************************
implicit none
c ---------------------------------------------------------------------------
c Declaration of subroutine parameters
c ---------------------------------------------------------------------------
integer flag ! Boolean flag whether trajectory is selected
character*80 cmd ! Command string
integer ntim,ncol ! Dimension of single trajectory
real tra(ntim,ncol) ! Single trajectory
character*80 vars(ncol) ! Name of columns
real times(ntim) ! List of times
integer nparam ! # parameters
real param(nparam) ! List of parameters
c ---------------------------------------------------------------------------
c Declaration of local variables
c ---------------------------------------------------------------------------
integer i
integer ip,i0,i1
c -------------------------------------------------------------------------- %)
c SPECIAL:WCB:ascent,first,last %)
c : Detect Warm Conveyor Belts (WCB); the air stream must ascend at least %)
c : <ascent=param(1)> hPa between the two times <first=param(2)> and %)
c : <last=param(3)>. Note, the lowest pressure is allowed to occur at any %)
c : time between <first> and <last>. %)
c --------------------------------------------------------------------------- %)
if ( cmd.eq.'WCB' ) then
c Reset the flag for selection
flag = 0
c Pressure is in the 4th column
ip = 4
c Get times
i0 = 0
i1 = 0
do i=1,ntim
if ( param(2).eq.times(i) ) i0 = i
if ( param(3).eq.times(i) ) i1 = i
enddo
if ( (i0.eq.0).or.(i1.eq.0) ) then
print*,' ERROR: invalid times in SPECIAL:WCB... Stop'
stop
endif
c Check for ascent
do i=i0+1,i1
if ( ( tra(i0,ip)-tra(i,ip) ) .gt. param(1) ) flag = 1
enddo
endif
c ---------------------------------------------------------------------------
end

/tags/1.0/trace/calvar.f
0,0 → 1,859
c -------------------------------------------------------------------------
c Potential temperature (TH)
c -------------------------------------------------------------------------
subroutine calc_TH (pt,t,p)
implicit none
c Argument declaration
real pt ! Potential temperature [K]
real t ! Temperature [either in C or in K]
real p ! Pressure [hPa]
c Physical parameters
real rdcp,tzero
data rdcp,tzero /0.286,273.15/
c Calculation - distinction between temperature in C or in K
if (t.lt.100.) then
pt = (t+tzero) * ( (1000./p)**rdcp )
else
pt = t * ( (1000./p)**rdcp )
endif
end
c -------------------------------------------------------------------------
c Density (RHO)
c -------------------------------------------------------------------------
subroutine calc_RHO (rho,t,p)
implicit none
c Argument declaration
real rho ! Density [kg/m^3]
real t ! Temperature [either in C or in K]
real p ! Pressure [hPa]
c Physical parameters
real rd,tzero
data rd,tzero /287.05,273.15/
c Auxiliary variables
real tk
c Calculation - distinction between temperature in C or in K
if (t.lt.100.) then
tk = t + tzero
else
tk = t
endif
rho = 100.*p/( tk * rd )
end
c -------------------------------------------------------------------------
c Relative humidity (RH)
c -------------------------------------------------------------------------
subroutine calc_RH (rh,t,p,q)
implicit none
c Argument declaration
real rh ! Relative humidity [%]
real t ! Temperature [either in C or in K]
real p ! Pressure [hPa]
real q ! Specific humidity [kg/kg]
c Physical parameters
real rdcp,tzero
data rdcp,tzero /0.286,273.15/
real b1,b2w,b3,b4w,r,rd
data b1,b2w,b3,b4w,r,rd /6.1078, 17.2693882, 273.16, 35.86,
& 287.05, 461.51/
c Auxiliary variables
real ge
real gqd
real tc
real pp,qk
c Calculation - distinction between temperature in C or in K
if (t.gt.100.) then
tc = t - tzero
else
tc = t
endif
qk = q
ge = b1*exp(b2w*tc/(tc+b3-b4w))
gqd = r/rd*ge/(p-(1.-r/rd)*ge)
rh = 100.*qk/gqd
end
c -------------------------------------------------------------------------
c Equivalent potential temperature (THE)
c -------------------------------------------------------------------------
subroutine calc_THE (the,t,p,q)
implicit none
c Argument declaration
real the ! Equivalent potential temperature [K]
real t ! Temperature [either in C or in K]
real p ! Pressure [hPa]
real q ! Specific humidity [kg/kg]
c Physical parameters
real rdcp,tzero
data rdcp,tzero /0.286,273.15/
c Auxiliary variables
real tk,qk
c Calculation - distinction between temperature in C or in K
if (t.lt.100.) then
tk = t + tzero
else
tk = t
endif
qk = q
the = tk*(1000./p)
+ **(0.2854*(1.0-0.28*qk))*exp(
+ (3.376/(2840.0/(3.5*alog(tk)-alog(
+ 100.*p*max(1.0E-10,qk)/(0.622+0.378*
+ q))-0.1998)+55.0)-0.00254)*1.0E3*
+ max(1.0E-10,qk)*(1.0+0.81*qk))
end
c -------------------------------------------------------------------------
c Latent heating rate (LHR)
c -------------------------------------------------------------------------
subroutine calc_LHR (lhr,t,p,q,omega,rh)
implicit none
c Argument declaration
real lhr ! Latent heating rate [K/6h]
real t ! Temperature [either in C or in K]
real p ! Pressure [hPa]
real q ! Specific humidity [kg/kg]
real omega ! Vertical velocity [Pa/s]
real rh ! Relative humidity [%]
c Physical parameters
real p0,kappa,tzero
data p0,kappa,tzero /1000.,0.286,273.15/
real blog10,cp,r,lw,eps
data blog10,cp,r,lw,eps /.08006,1004.,287.,2.5e+6,0.622/
c Auxiliary variables
real tk
real qk
real tt
real esat,c
c Calculation - distinction between temperature in C or in K
if (t.lt.100.) then
tk = t + tzero
else
tk = t
endif
qk = q
if (rh.lt.80.) then
lhr = 0.
else if (omega.gt.0.) then
lhr = 0.
else
c = lw/cp*eps*blog10*esat(tk)/p
tt = (tk*(p0/p)**kappa)
lhr = 21600.*
> (1.-exp(.2*(80.-rh)))
> *(-c*kappa*tt*omega/(100.*p))/(1.+c)
endif
end
c -------------------------------------------------------------------------
c Wind speed (VEL)
c -------------------------------------------------------------------------
subroutine calc_VEL (vel,u,v)
implicit none
c Argument declaration
real vel ! Wind speed [m/s]
real u ! Zonal wind component [m/s]
real v ! Meridional wind component [m/s]
vel = sqrt ( u*u + v*v )
end
c -------------------------------------------------------------------------
c Wind direction (DIR)
c -------------------------------------------------------------------------
subroutine calc_DIR (dir,u,v)
implicit none
c Argument declaration
real dir ! Wind direction [deg]
real u ! Zonal wind component [m/s]
real v ! Meridional wind component [m/s]
call getangle(1.,0.,u,v,dir)
end
c -------------------------------------------------------------------------
c Zonal derivative of U (DUDX)
c -------------------------------------------------------------------------
subroutine calc_DUDX (dudx,u1,u0,lat)
implicit none
c Argument declaration
real dudx ! Derivative of U in zonal direction [s^-1]
real u1 ! U @ LON + 1 DLON [m/s]
real u0 ! U @ LON - 1 DLON [m/s]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=31.14159/180.)
real deltay
parameter (deltay =1.11e5)
dudx = (u1-u0) / ( 2. * deltay * cos(pi180 * lat) )
end
c -------------------------------------------------------------------------
c Zonal derivative of V (DVDX)
c -------------------------------------------------------------------------
subroutine calc_DVDX (dvdx,v1,v0,lat)
c Argument declaration
real dvdx ! Derivative of V in zonal direction [s^-1]
real v1 ! V @ LON + 1 DLON [m/s]
real v0 ! V @ LON - 1 DLON [m/s]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
dvdx = (v1-v0) / ( 2. * deltay * cos(pi180 * lat) )
end
c -------------------------------------------------------------------------
c Zonal derivative of T (DTDX)
c -------------------------------------------------------------------------
subroutine calc_DTDX (dtdx,t1,t0,lat)
implicit none
c Argument declaration
real dtdx ! Derivative of T in zonal direction [K/m]
real t1 ! T @ LON + 1 DLON [K]
real t0 ! T @ LON - 1 DLON [K]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
dtdx = (t1-t0) / ( 2. * deltay * cos(pi180 * lat) )
end
c -------------------------------------------------------------------------
c Zonal derivative of TH (DTHDX)
c -------------------------------------------------------------------------
subroutine calc_DTHDX (dthdx,t1,t0,p,lat)
implicit none
c Argument declaration
real dthdx ! Derivative of TH in zonal direction [K/m]
real t1 ! T @ LON + 1 DLON [K]
real t0 ! T @ LON - 1 DLON [K]
real p ! P [hPa]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
real rdcp,pref
data rdcp,pref /0.286,1000./
dthdx = (pref/p)**rdcp *
> (t1-t0) / ( 2. * deltay * cos(pi180 * lat) )
end
c -------------------------------------------------------------------------
c Meridional derivative of U (DUDY)
c -------------------------------------------------------------------------
subroutine calc_DUDY (dudy,u1,u0)
implicit none
c Argument declaration
real dudy ! Derivative of U in meridional direction [s^-1]
real u1 ! U @ LAT + 1 DLAT [m/s]
real u0 ! U @ LAT - 1 DLAT [m/s]
c Physical parameters
real deltay
parameter (deltay =1.11e5)
dudy = (u1-u0) / ( 2. * deltay )
end
c -------------------------------------------------------------------------
c Meridional derivative of V (DVDY)
c -------------------------------------------------------------------------
subroutine calc_DVDY (dvdy,v1,v0)
implicit none
c Argument declaration
real dvdy ! Derivative of V in meridional direction [s^-1]
real v1 ! V @ LAT + 1 DLAT [m/s]
real v0 ! V @ LAT - 1 DLAT [m/s]
c Physical parameters
real deltay
parameter (deltay =1.11e5)
dvdy = (v1-v0) / ( 2. * deltay )
end
c -------------------------------------------------------------------------
c Meridional derivative of T (DTDY)
c -------------------------------------------------------------------------
subroutine calc_DTDY (dtdy,t1,t0)
implicit none
c Argument declaration
real dtdy ! Derivative of T in meridional direction [K/m]
real t1 ! T @ LAT + 1 DLAT [K]
real t0 ! T @ LAT - 1 DLAT [K]
c Physical parameters
real deltay
parameter (deltay =1.11e5)
dtdy = (t1-t0) / ( 2. * deltay )
end
c -------------------------------------------------------------------------
c Meridional derivative of TH (DTHDY)
c -------------------------------------------------------------------------
subroutine calc_DTHDY (dthdy,t1,t0,p)
implicit none
c Argument declaration
real dthdy ! Derivative of TH in meridional direction [K/m]
real t1 ! TH @ LAT + 1 DLAT [K]
real t0 ! TH @ LAT - 1 DLAT [K]
real p ! P [hPa]
c Physical parameters
real deltay
parameter (deltay =1.11e5)
real rdcp,pref
data rdcp,pref /0.286,1000./
dthdy = (pref/p)**rdcp * (t1-t0) / ( 2. * deltay )
end
c -------------------------------------------------------------------------
c Wind shear of U (DUDP)
c -------------------------------------------------------------------------
subroutine calc_DUDP (dudp,u1,u0,p1,p0)
implicit none
c Argument declaration
real dudp ! Wind shear [m/s per Pa]
real u1 ! U @ P + 1 DP [m/s]
real u0 ! U @ P - 1 DP [m/s]
real p1 ! P + 1 DP [hPa]
real p0 ! P - 1 DP [hPa]
dudp = 0.01 * (u1-u0) / (p1-p0)
end
c -------------------------------------------------------------------------
c Wind shear of V (DVDP)
c -------------------------------------------------------------------------
subroutine calc_DVDP (dvdp,v1,v0,p1,p0)
implicit none
c Argument declaration
real dvdp ! Wind shear [m/s per Pa]
real v1 ! V @ P + 1 DP [m/s]
real v0 ! V @ P - 1 DP [m/s]
real p1 ! P + 1 DP [hPa]
real p0 ! P - 1 DP [hPa]
dvdp = 0.01 * (v1-v0) / (p1-p0)
end
c -------------------------------------------------------------------------
c Vertical derivative of T (DTDP)
c -------------------------------------------------------------------------
subroutine calc_DTDP (dtdp,t1,t0,p1,p0)
implicit none
c Argument declaration
real dtdp ! Vertical derivative of T [K/Pa]
real t1 ! T @ P + 1 DP [K]
real t0 ! T @ P - 1 DP [K]
real p1 ! P + 1 DP [hPa]
real p0 ! P - 1 DP [hPa]
dtdp = 0.01 * (t1-t0) / (p1-p0)
end
c -------------------------------------------------------------------------
c Vertical derivative of TH (DTHDP)
c -------------------------------------------------------------------------
subroutine calc_DTHDP (dthdp,t1,t0,p1,p0,p,t)
implicit none
c Argument declaration
real dthdp ! Vertical derivative of TH [K/Pa]
real t1 ! T @ P + 1 DP [K]
real t0 ! T @ P - 1 DP [K]
real t ! T [K]
real p1 ! P + 1 DP [hPa]
real p0 ! P - 1 DP [hPa]
real p ! P [hPa]
c Physical parameters
real rdcp,tzero,pref
data rdcp,tzero,pref /0.286,273.15,1000./
c Auxiliary variables
real tk1,tk0,tk
if (t0.lt.100.) then
tk0 = t0 + tzero
endif
if (t1.lt.100.) then
tk1 = t1 + tzero
endif
if (t.lt.100.) then
tk = t + tzero
endif
dthdp = 0.01*(pref/p)**rdcp *
> ( (tk1-tk0)/(p1-p0) - rdcp * tk/p )
end
c -------------------------------------------------------------------------
c Squared Brunt-Vaisäla frequency (NSQ)
c -------------------------------------------------------------------------
subroutine calc_NSQ (nsq,dthdp,th,rho)
implicit none
c Argument declaration
real nsq ! Squared Brunt-Vaisäla frequency [s^-1]
real dthdp ! D(TH)/DP [K/Pa]
real th ! K
real rho ! Density [kg m^-3]
c Physical parameters
real g
parameter (g=9.81)
nsq = -g**2/th * rho * dthdp
end
c -------------------------------------------------------------------------
c Relative vorticity (RELVORT)
c -------------------------------------------------------------------------
subroutine calc_RELVORT (relvort,dudy,dvdx,u,lat)
implicit none
c Argument declaration
real relvort ! Relative vorticity [s^-1]
real u ! Zonal wind component [m/s]
real dudy ! du/dy [s^-1]
real dvdx ! dv/dx [s^-1]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
relvort = dvdx - dudy + u * pi180/deltay * tan(pi180 * lat)
end
c -------------------------------------------------------------------------
c Absolute vorticity (ABSVORT)
c -------------------------------------------------------------------------
subroutine calc_ABSVORT (absvort,dudy,dvdx,u,lat)
implicit none
c Argument declaration
real absvort ! Absolute vorticity [s^-1]
real u ! Zonal wind component [m/s]
real dudy ! du/dy [s^-1]
real dvdx ! dv/dx [s^-1]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
real omega
parameter (omega=7.292e-5)
absvort = dvdx - dudy + u * pi180/deltay * tan(pi180 * lat) +
> 2. * omega * sin(pi180 * lat)
end
c -------------------------------------------------------------------------
c Divergence (DIV)
c -------------------------------------------------------------------------
subroutine calc_DIV (div,dudx,dvdy,v,lat)
implicit none
c Argument declaration
real div ! Divergence [s^-1]
real v ! Meridional wind component [m/s]
real dudx ! du/dx [s^-1]
real dvdy ! dv/dy [s^-1]
real lat ! Latitude [deg]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
real deltay
parameter (deltay =1.11e5)
div = dudx + dvdy - v * pi180/deltay * tan(pi180 * lat)
end
c -------------------------------------------------------------------------
c Deformation (DEF)
c -------------------------------------------------------------------------
subroutine calc_DEF (def,dudx,dvdx,dudy,dvdy)
implicit none
c Argument declaration
real def ! Deformation [s^-1]
real dudx ! du/dx [s^-1]
real dvdx ! dv/dy [s^-1]
real dudy ! du/dx [s^-1]
real dvdy ! dv/dy [s^-1]
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
def = sqrt( (dvdx+dudy)**2 + (dudx-dvdy)**2 )
end
c -------------------------------------------------------------------------
c Potential Vorticity (PV)
c -------------------------------------------------------------------------
subroutine calc_PV (pv,absvort,dthdp,dudp,dvdp,dthdx,dthdy)
implicit none
c Argument declaration
real pv ! Ertel-PV [PVU]
real absvort ! Absolute vorticity [s^-1]
real dthdp ! dth/dp [K/Pa]
real dudp ! du/dp [m/s per Pa]
real dvdp ! dv/dp [m/s per Pa]
real dthdx ! dth/dx [K/m]
real dthdy ! dth/dy [K/m]
c Physical and numerical parameters
real scale
parameter (scale=1.E6)
real g
parameter (g=9.80665)
pv = -scale * g * ( absvort * dthdp + dudp * dthdy - dvdp * dthdx)
end
c -------------------------------------------------------------------------
c Richardson number (RI)
c -------------------------------------------------------------------------
subroutine calc_RI (ri,dudp,dvdp,nsq,rho)
implicit none
c Argument declaration
real ri ! Richardson number
real dudp ! Du/Dp [m/s per Pa]
real dvdp ! Dv/Dp [m/s per Pa]
real nsq ! Squared Brunt-Vailälä frequency [s^-1]
real rho ! Density [kg/m^3]
c Physical and numerical parameters
real g
parameter (g=9.80665)
ri = nsq / ( dudp**2 + dvdp**2 ) / ( rho * g )**2
end
c -------------------------------------------------------------------------
c Ellrod and Knapp's turbulence indicator (TI)
c -------------------------------------------------------------------------
subroutine calc_TI (ti,def,dudp,dvdp,rho)
implicit none
c Argument declaration
real ti ! Turbulence idicator
real def ! Deformation [s^-1]
real dudp ! Du/Dp [m/s per Pa]
real dvdp ! Dv/Dp [m/s per Pa]
real rho ! Density [kg/m^3]
c Physical and numerical parameters
real g
parameter (g=9.80665)
ti = def * sqrt ( dudp**2 + dvdp**2 ) * ( rho * g )
end
c -------------------------------------------------------------------------
c Distance from starting position
c -------------------------------------------------------------------------
subroutine calc_DIST0 (dist0,lon0,lat0,lon1,lat1)
implicit none
c Argument declaration
real dist0 ! Distance from starting position [km]
real lon0,lat0 ! Starting position
real lon1,lat1 ! New position
c Externals
real sdis
external sdis
dist0 = sdis(lon0,lat0,lon1,lat1)
end
c -------------------------------------------------------------------------
c Heading of the trajectory (HEAD)
c -------------------------------------------------------------------------
subroutine calc_HEAD (head,lon0,lat0,lon1,lat1)
implicit none
c Argument declaration
real head ! Heading angle (in deg) relativ to zonal direction
real lon0,lat0 ! Starting position
real lon1,lat1 ! New position
c Physical parameters
real pi180
parameter (pi180=3.14159/180.)
c Auixiliary variables
real dx,dy
dx = (lon1-lon0) * cos(pi180*0.5*(lat0+lat1))
dy = lat1-lat0
call getangle(1.,0.,dx,dy,head)
end
c
c *************************************************************************
c Auxiliary subroutines and functions
c *************************************************************************
c -------------------------------------------------------------------------
c Saturation vapor pressure over water
c -------------------------------------------------------------------------
real function esat(t)
C This function returns the saturation vapor pressure over water
c (mb) given the temperature (Kelvin).
C The algorithm is due to Nordquist, W. S. ,1973: "Numerical
C Approximations of Selected Meteorological Parameters for Cloud
C Physics Problems" ECOM-5475, Atmospheric Sciences Laboratory,
c U. S. Army Electronics Command, White Sands Missile Range,
c New Mexico 88002.
real p1,p2,c1,t
p1=11.344-0.0303998*t
p2=3.49149-1302.8844/t
c1=23.832241-5.02808*log10(t)
esat=10.**(c1-1.3816e-7*10.**p1+8.1328e-3*10.**p2-2949.076/t)
end
c --------------------------------------------------------------------------
c Angle between two vectors
c --------------------------------------------------------------------------
SUBROUTINE getangle (ux1,uy1,ux2,uy2,angle)
c Given two vectors <ux1,uy1> and <ux2,uy2>, determine the angle (in deg)
c between the two vectors.
implicit none
c Declaration of subroutine parameters
real ux1,uy1
real ux2,uy2
real angle
c Auxiliary variables and parameters
real len1,len2,len3
real val1,val2,val3
real vx1,vy1
real vx2,vy2
real pi
parameter (pi=3.14159265359)
vx1 = ux1
vx2 = ux2
vy1 = uy1
vy2 = uy2
len1=sqrt(vx1*vx1+vy1*vy1)
len2=sqrt(vx2*vx2+vy2*vy2)
if ((len1.gt.0.).and.(len2.gt.0.)) then
vx1=vx1/len1
vy1=vy1/len1
vx2=vx2/len2
vy2=vy2/len2
val1=vx1*vx2+vy1*vy2
val2=-vy1*vx2+vx1*vy2
len3=sqrt(val1*val1+val2*val2)
if ( (val1.ge.0.).and.(val2.ge.0.) ) then
val3=acos(val1/len3)
else if ( (val1.lt.0.).and.(val2.ge.0.) ) then
val3=pi-acos(abs(val1)/len3)
else if ( (val1.ge.0.).and.(val2.le.0.) ) then
val3=-acos(val1/len3)
else if ( (val1.lt.0.).and.(val2.le.0.) ) then
val3=-pi+acos(abs(val1)/len3)
endif
else
val3=0.
endif
angle=180./pi*val3
END
c --------------------------------------------------------------------------
c Spherical distance between lat/lon points
c --------------------------------------------------------------------------
real function sdis(xp,yp,xq,yq)
c
c calculates spherical distance (in km) between two points given
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
c
real re
parameter (re=6370.)
real pi180
parameter (pi180=3.14159/180.)
real xp,yp,xq,yq,arg
arg=sin(pi180*yp)*sin(pi180*yq)+
> cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
if (arg.lt.-1.) arg=-1.
if (arg.gt.1.) arg=1.
sdis=re*acos(arg)
end

/tags/1.0/trace/trace.f90
0,0 → 1,2155
PROGRAM trace
! ********************************************************************
! * *
! * Trace fields along trajectories *
! * *
! * April 1993: First version (Heini Wernli) *
! * 2008-2009 : Major upgrades (Michael Sprenger) *
! * Mar 2012: Clustering option (Bojan Skerlak) *
! * Nov 2012: Circle options (") *
! * Jul 2013: user-defined PV,TH @ clustering mode (") *
! * *
! ********************************************************************
implicit none
! --------------------------------------------------------------------
! Declaration of parameters
! --------------------------------------------------------------------
! Maximum number of levels for input files
integer :: nlevmax
parameter (nlevmax=100)
! Maximum number of input files (dates, length of trajectories)
integer :: ndatmax
parameter (ndatmax=500)
! Numerical epsilon (for float comparison)
real :: eps
parameter (eps=0.001)
! Conversion factors
real :: pi180 ! deg -> rad
parameter (pi180=3.14159/180.)
real :: deg2km ! deg -> km (at equator)
parameter (deg2km=111.)
real :: pir
parameter (pir=255032235.95489) ! 2*Pi*R^2 Bojan
! Prefix for primary and secondary fields
character :: charp
character :: chars
parameter (charp='P')
parameter (chars='S')
! --------------------------------------------------------------------
! Declaration of variables
! --------------------------------------------------------------------
! Input and output format for trajectories (see iotra.f)
integer :: inpmode
integer :: outmode
! Input parameters
character(len=80) :: inpfile ! Input trajectory file
character(len=80) :: outfile ! Output trajectory file
integer :: ntra ! Number of trajectories
integer :: ncol ! Number of columns (including time, lon, lat, p)
integer :: ntim ! Number of times per trajectory
integer :: ntrace0 ! Number of trace variables
character(len=80) :: tvar0(200) ! Tracing variable (with mode specification)
character(len=80) :: tvar(200) ! Tracing variable name (only the variable)
character(len=1) :: tfil(200) ! Filename prefix
real :: fac(200) ! Scaling factor
real :: shift_val(200) ! Shift in space and time relative to trajectory position
character(len=80) :: shift_dir(200) ! Direction of shift
integer :: compfl(200) ! Computation flag (1=compute)
integer :: numdat ! Number of input files
character(len=11) :: dat(ndatmax) ! Dates of input files
real :: timeinc ! Time increment between input files
real :: tst ! Time shift of start relative to first data file
real :: ten ! Time shift of end relatiev to first data file
character(len=20) :: startdate ! First time/date on trajectory
character(len=20) :: enddate ! Last time/date on trajectory
integer :: ntrace1 ! Count trace and additional variables
character(len=80) :: timecheck ! Either 'yes' or 'no'
character(len=80) :: intmode ! Interpolation mode ('normal', 'nearest') Bojan ('clustering','circle_avg','circle_max','circle_min')
! Trajectories
real,allocatable, dimension (:,:,:) :: trainp ! Input trajectories (ntra,ntim,ncol)
real,allocatable, dimension (:,:,:) :: traint ! Internal trajectories (ntra,ntim,ncol+ntrace1)
real,allocatable, dimension (:,:,:) :: traout ! Output trajectories (ntra,ntim,ncol+ntrace0)
integer :: reftime(6) ! Reference date
character(len=80) :: varsinp(100) ! Field names for input trajectory
character(len=80) :: varsint(100) ! Field names for internal trajectory
character(len=80) :: varsout(100) ! Field names for output trajectory
integer :: fid,fod ! File identifier for inp and out trajectories
real :: x0,y0,p0 ! Position of air parcel (physical space)
real :: reltpos0 ! Relative time of air parcel
real :: xind,yind,pind ! Position of air parcel (grid space)
integer :: fbflag ! Flag for forward (1) or backward (-1) trajectories
integer :: fok(100) ! Flag whether field is ready
! Meteorological fields
real,allocatable, dimension (:) :: spt0,spt1 ! Surface pressure
real,allocatable, dimension (:) :: p3t0,p3t1 ! 3d-pressure
real,allocatable, dimension (:) :: f3t0,f3t1 ! 3d field for tracing
character(len=80) :: svars(100) ! List of variables on S file
character(len=80) :: pvars(100) ! List of variables on P file
integer :: n_svars ! Number of variables on S file
integer :: n_pvars ! Number of variables on P file
! Grid description
real :: pollon,pollat ! Longitude/latitude of pole
real :: ak(100) ! Vertical layers and levels
real :: bk(100)
real :: xmin,xmax ! Zonal grid extension
real :: ymin,ymax ! Meridional grid extension
integer :: nx,ny,nz ! Grid dimensions
real :: dx,dy ! Horizontal grid resolution
integer :: hem ! Flag for hemispheric domain
integer :: per ! Flag for periodic domain
real :: stagz ! Vertical staggering
real :: mdv ! Missing data value
! Auxiliary variables
integer :: i,j,k,l,m,n
real :: rd
character(len=80) :: filename,varname
real :: time0,time1,reltpos
integer :: itime0,itime1
integer :: stat
real :: tstart
integer :: iloaded0,iloaded1
real :: f0
real :: frac
real :: tload,tfrac
integer :: isok
character :: ch
integer :: ind
integer :: ind1,ind2,ind3,ind4,ind5
integer :: ind6,ind7,ind8,ind9,ind0
integer :: noutside
real :: delta
integer :: itrace0
character(len=80) :: string
integer err_c1,err_c2,err_c3
! Bojan
real :: dist,circlesum,circlemax,circlemin,circleavg,radius ! distance (great circle), sum/max/min/avg in circle, radius of circle
integer :: ist,jst,kst,sp,ml,mr,nd,nu ! ijk in stack, sp=stack counter, ml (left), mr (right), nd (down), nu (up)
integer :: lci,lcj,xindb,xindf ! label count i and j, xind back, xind forward
integer :: yindb,yindf,pindb,pindf ! yind back, yind forward, pind back, pind forward
integer :: pvpos,thpos ! position of variables PV and TH in trajectory
real :: tropo_pv,tropo_th ! values of PV and TH at dynamical tropopause
integer, allocatable, dimension (:) :: stackx,stacky ! lon/lat of stack
integer, allocatable, dimension (:) :: lblcount ! counter for label
integer, allocatable, dimension (:,:) :: connect ! array that keeps track of the visited grid points
real, allocatable, dimension (:) :: lbl ! label
real, allocatable, dimension (:) :: circlelon,circlelat ! value of f, lon and lat in circle
real, allocatable, dimension (:) :: circlef,circlearea ! value of f, lon and lat in circle
real, allocatable, dimension (:) :: longrid,latgrid ! arrays of longitude and latitude of grid points
! Bojan
! Externals
real :: int_index4
external int_index4
real :: sdis ! Bojan: need function sdis (calculates great circle distance)
external sdis ! Bojan: need function sdis
! --------------------------------------------------------------------
! Start of program, Read parameters, get grid parameters
! --------------------------------------------------------------------
! Write start message
print*,'========================================================='
print*,' *** START OF PROGRAM TRACE ***'
print*
! Read parameters
open(10,file='trace.param')
read(10,*) inpfile
read(10,*) outfile
read(10,*) startdate
read(10,*) enddate
read(10,*) fbflag
read(10,*) numdat
if ( fbflag.eq.1) then
do i=1,numdat
read(10,'(a11)') dat(i)
enddo
else
do i=numdat,1,-1
read(10,'(a11)') dat(i)
enddo
endif
read(10,*) timeinc
read(10,*) tst
read(10,*) ten
read(10,*) ntra
read(10,*) ntim
read(10,*) ncol
read(10,*) ntrace0
do i=1,ntrace0
read(10,*) tvar(i), fac(i), compfl(i), tfil(i)
enddo
read(10,*) n_pvars
do i=1,n_pvars
read(10,*) pvars(i)
enddo
read(10,*) n_svars
do i=1,n_svars
read(10,*) svars(i)
enddo
read(10,*) timecheck
read(10,*) intmode
read(10,*) radius
read(10,*) tropo_pv
read(10,*) tropo_th
close(10)
! Bojan: error if radius < 0
if (((intmode .eq. "circle_avg") .or. (intmode .eq. "circle_min") .or. (intmode .eq. "circle_max")) .and. (radius .lt. 0)) then
print*,'ERROR (circle): radius < 0!'
stop
endif
! Remove commented tracing fields
itrace0 = 1
do while ( itrace0.le.ntrace0)
string = tvar(itrace0)
if ( string(1:1).eq.'#' ) then
do i=itrace0,ntrace0-1
tvar(i) = tvar(i+1)
fac(i) = fac(i+1)
compfl(i) = compfl(i+1)
tfil(i) = tfil(i+1)
enddo
ntrace0 = ntrace0 - 1
else
itrace0 = itrace0 + 1
endif
enddo
! Save the tracing variable (including all mode specifications)
do i=1,ntrace0
tvar0(i) = tvar(i)
enddo
! Set the formats of the input and output files
call mode_tra(inpmode,inpfile)
if (inpmode.eq.-1) inpmode=1
call mode_tra(outmode,outfile)
if (outmode.eq.-1) outmode=1
! Convert time shifts <tst,ten> from <hh.mm> into fractional time
call hhmm2frac(tst,frac)
tst = frac
call hhmm2frac(ten,frac)
ten = frac
! Set the time for the first data file (depending on forward/backward mode)
if (fbflag.eq.1) then
tstart = -tst
else
tstart = tst
endif
! Read the constant grid parameters (nx,ny,nz,xmin,xmax,ymin,ymax,pollon,pollat)
! The negative <-fid> of the file identifier is used as a flag for parameter retrieval
filename = charp//dat(1)
varname = 'U'
call input_open (fid,filename)
call input_grid (-fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,tstart,pollon,pollat,rd,rd,nz,rd,rd,rd,timecheck)
call input_close(fid)
! Allocate memory for some meteorological arrays
allocate(spt0(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt0 ***' ! Surface pressure
allocate(spt1(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating array spt1 ***'
allocate(p3t0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t0 ***' ! Pressure
allocate(p3t1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
allocate(f3t0(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t0 ***' ! Tracing field
allocate(f3t1(nx*ny*nz),stat=stat)
if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
! Get memory for trajectory arrays
allocate(trainp(ntra,ntim,ncol),stat=stat)
if (stat.ne.0) print*,'*** error allocating array tra ***'
! Bojan
! allocate memory for clustering mode
if (intmode .eq. 'clustering') then
allocate(lbl(8),stat=stat)
if (stat.ne.0) print*,'*** error allocating array lbl ***'
allocate(lblcount(5),stat=stat)
if (stat.ne.0) print*,'*** error allocating array lblcount ***'
endif
! allocate memory for circle mode
if ( (intmode.eq.'circle_avg') .or. (intmode.eq.'circle_min') .or. (intmode.eq.'circle_max') ) then
allocate(connect(nx,ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating connect ***'
allocate(stackx(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating stackx ***'
allocate(stacky(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating stacky ***'
allocate(circlelon(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating circlelon ***'
allocate(circlelat(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating circlelat ***'
allocate(circlef(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating circlef ***'
allocate(circlearea(nx*ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating circlearea ***'
allocate(longrid(nx),stat=stat)
if (stat.ne.0) print*,'*** error allocating longrid ***'
allocate(latgrid(ny),stat=stat)
if (stat.ne.0) print*,'*** error allocating latgrid ***'
do m=1,nx
longrid(m)=xmin+dx*(m-1)
enddo
do n=1,ny
latgrid(n)=ymin+dy*(n-1)
enddo
endif
! Bojan
! Set the flags for periodic domains
if ( abs(xmax-xmin-360.).lt.eps ) then
per = 1
elseif ( abs(xmax-xmin-360.+dx).lt.eps ) then
per = 2
else
per = 0
endif
! Set logical flag for periodic data set (hemispheric or not)
hem = 0
if (per.eq.0.) then
delta=xmax-xmin-360.
if (abs(delta+dx).lt.eps) then ! Program aborts: arrays must be closed
print*,' ERROR: arrays must be closed... Stop'
else if (abs(delta).lt.eps) then ! Periodic and hemispheric
hem=1
per=360.
endif
else ! Periodic and hemispheric
hem=1
endif
! Write some status information
print*,'---- INPUT PARAMETERS -----------------------------------'
print*
print*,' Input trajectory file : ',trim(inpfile)
print*,' Output trajectory file : ',trim(outfile)
print*,' Format of input file : ',inpmode
print*,' Format of output file : ',outmode
print*,' Forward/backward : ',fbflag
print*,' #tra : ',ntra
print*,' #col : ',ncol
print*,' #tim : ',ntim
print*,' No time check : ',trim(timecheck)
print*,' Interpolation mode : ',trim(intmode)
! Bojan
if (trim(intmode) .eq. "clustering") then
print*,' Tropopause PV [pvu] : ',tropo_pv
print*,' Tropopause TH [K] : ',tropo_th
endif
do i=1,ntrace0
if (compfl(i).eq.0) then
print*,' Tracing field : ', trim(tvar(i)), fac(i), ' 0 ', tfil(i)
else
print*,' Tracing field : ', trim(tvar(i)), fac(i), ' 1 ', tfil(i)
endif
enddo
print*
print*,'---- INPUT DATA FILES -----------------------------------'
print*
call frac2hhmm(tstart,tload)
print*,' Time of 1st data file : ',tload
print*,' #input files : ',numdat
print*,' time increment : ',timeinc
call frac2hhmm(tst,tload)
print*,' Shift of start : ',tload
call frac2hhmm(ten,tload)
print*,' Shift of end : ',tload
print*,' First/last input file : ',trim(dat(1)), ' ... ', trim(dat(numdat))
print*,' Primary variables : ',trim(pvars(1))
do i=2,n_pvars
print*,' : ',trim(pvars(i))
enddo
if ( n_svars.ge.1 ) then
print*,' Secondary variables : ',trim(svars(1))
do i=2,n_svars
print*,' : ',trim(svars(i))
enddo
endif
print*
print*,'---- CONSTANT GRID PARAMETERS ---------------------------'
print*
print*,' xmin,xmax : ',xmin,xmax
print*,' ymin,ymax : ',ymin,ymax
print*,' dx,dy : ',dx,dy
print*,' pollon,pollat : ',pollon,pollat
print*,' nx,ny,nz : ',nx,ny,nz
print*,' per, hem : ',per,hem
print*
! --------------------------------------------------------------------
! Load the input trajectories
! --------------------------------------------------------------------
! Read the input trajectory file
call ropen_tra(fid,inpfile,ntra,ntim,ncol,reftime,varsinp,inpmode)
call read_tra (fid,trainp,ntra,ntim,ncol,inpmode)
call close_tra(fid,inpmode)
! Check that first four columns correspond to time,lon,lat,p
if ( (varsinp(1).ne.'time' ).or. &
(varsinp(2).ne.'xpos' ).and.(varsinp(2).ne.'lon' ).or. &
(varsinp(3).ne.'ypos' ).and.(varsinp(3).ne.'lat' ).or. &
(varsinp(4).ne.'ppos' ).and.(varsinp(4).ne.'p' ) ) then
print*,' ERROR: problem with input trajectories ...'
stop
endif
varsinp(1) = 'time'
varsinp(2) = 'lon'
varsinp(3) = 'lat'
varsinp(4) = 'p'
! Write some status information of the input trajectories
print*,'---- INPUT TRAJECTORIES ---------------------------------'
print*
print*,' Start date : ',trim(startdate)
print*,' End date : ',trim(enddate)
print*,' Reference time (year) : ',reftime(1)
print*,' (month) : ',reftime(2)
print*,' (day) : ',reftime(3)
print*,' (hour) : ',reftime(4)
print*,' (min) : ',reftime(5)
print*,' Time range (min) : ',reftime(6)
do i=1,ncol
print*,' Var :',i,trim(varsinp(i))
enddo
print*
! Check that first time is 0 - otherwise the tracing will produce
! wrong results because later in the code only absolute times are
! considered: <itime0 = int(abs(tfrac-tstart)/timeinc) + 1>. This
! will be changed in a future version.
if ( abs( trainp(1,1,1) ).gt.eps ) then
print*,' ERROR: First time of trajectory must be 0, i.e. '
print*,' correspond to the reference date. Otherwise'
print*,' the tracing will give wrong results... STOP'
stop
endif
! --------------------------------------------------------------------
! Check dependencies for trace fields which must be calculated
! --------------------------------------------------------------------
! Set the counter for extra fields
ntrace1 = ntrace0
! Loop over all tracing variables
i = 1
do while (i.le.ntrace1)
! Skip fields which must be available on the input files
if (i.le.ntrace0) then
if (compfl(i).eq.0) goto 100
endif
! Get the dependencies for potential temperature (TH)
if ( tvar(i).eq.'TH' ) then
varname='P' ! P
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
! Get the dependencies for potential temperature (TH)
elseif ( tvar(i).eq.'RHO' ) then
varname='P' ! P
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
! Get the dependencies for relative humidity (RH)
elseif ( tvar(i).eq.'RH' ) then
varname='P' ! P
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
varname='Q' ! Q
call add2list(varname,tvar,ntrace1)
! Get the dependencies for equivalent potential temperature (THE)
elseif ( tvar(i).eq.'THE' ) then
varname='P' ! P
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
varname='Q' ! Q
call add2list(varname,tvar,ntrace1)
! Get the dependencies for latent heating rate (LHR)
elseif ( tvar(i).eq.'LHR' ) then
varname='P' ! P
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
varname='Q' ! Q
call add2list(varname,tvar,ntrace1)
varname='OMEGA' ! OMEGA
call add2list(varname,tvar,ntrace1)
varname='RH' ! RH
call add2list(varname,tvar,ntrace1)
! Get the dependencies for wind speed (VEL)
elseif ( tvar(i).eq.'VEL' ) then
varname='U' ! U
call add2list(varname,tvar,ntrace1)
varname='V' ! V
call add2list(varname,tvar,ntrace1)
! Get the dependencies for wind direction (DIR)
elseif ( tvar(i).eq.'DIR' ) then
varname='U' ! U
call add2list(varname,tvar,ntrace1)
varname='V' ! V
call add2list(varname,tvar,ntrace1)
! Get the dependencies for du/dx (DUDX)
elseif ( tvar(i).eq.'DUDX' ) then
varname='U:+1DLON' ! U:+1DLON
call add2list(varname,tvar,ntrace1)
varname='U:-1DLON' ! U:-1DLON
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dv(dx (DVDX)
elseif ( tvar(i).eq.'DVDX' ) then
varname='V:+1DLON' ! V:+1DLON
call add2list(varname,tvar,ntrace1)
varname='V:-1DLON' ! V:-1DLON
call add2list(varname,tvar,ntrace1)
! Get the dependencies for du/dy (DUDY)
elseif ( tvar(i).eq.'DUDY' ) then
varname='U:+1DLAT' ! U:+1DLAT
call add2list(varname,tvar,ntrace1)
varname='U:-1DLAT' ! U:-1DLAT
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dv/dy (DVDY)
elseif ( tvar(i).eq.'DVDY' ) then
varname='V:+1DLAT' ! V:+1DLAT
call add2list(varname,tvar,ntrace1)
varname='V:-1DLAT' ! V:-1DLAT
call add2list(varname,tvar,ntrace1)
! Get the dependencies for du/dp (DUDP)
elseif ( tvar(i).eq.'DUDP' ) then
varname='U:+1DP' ! U:+1DP
call add2list(varname,tvar,ntrace1)
varname='U:-1DP' ! U:-1DP
call add2list(varname,tvar,ntrace1)
varname='P:+1DP' ! P:+1DP
call add2list(varname,tvar,ntrace1)
varname='P:-1DP' ! P:-1DP
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dv/dp (DVDP)
elseif ( tvar(i).eq.'DVDP' ) then
varname='V:+1DP' ! V:+1DP
call add2list(varname,tvar,ntrace1)
varname='V:-1DP' ! V:-1DP
call add2list(varname,tvar,ntrace1)
varname='P:+1DP' ! P:+1DP
call add2list(varname,tvar,ntrace1)
varname='P:-1DP' ! P:-1DP
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dt/dx (DTDX)
elseif ( tvar(i).eq.'DTDX' ) then
varname='T:+1DLON' ! T:+1DLON
call add2list(varname,tvar,ntrace1)
varname='T:-1DLON' ! T:-1DLON
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dth/dy (DTHDY)
elseif ( tvar(i).eq.'DTHDY' ) then
varname='T:+1DLAT' ! T:+1DLON
call add2list(varname,tvar,ntrace1)
varname='T:-1DLAT' ! T:-1DLON
call add2list(varname,tvar,ntrace1)
varname='P' ! P
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dth/dx (DTHDX)
elseif ( tvar(i).eq.'DTHDX' ) then
varname='T:+1DLON' ! T:+1DLON
call add2list(varname,tvar,ntrace1)
varname='T:-1DLON' ! T:-1DLON
call add2list(varname,tvar,ntrace1)
varname='P' ! P
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dt/dy (DTDY)
elseif ( tvar(i).eq.'DTDY' ) then
varname='T:+1DLAT' ! T:+1DLON
call add2list(varname,tvar,ntrace1)
varname='T:-1DLAT' ! T:-1DLON
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dt/dp (DTDP)
elseif ( tvar(i).eq.'DTDP' ) then
varname='T:+1DP' ! T:+1DP
call add2list(varname,tvar,ntrace1)
varname='T:-1DP' ! T:-1DP
call add2list(varname,tvar,ntrace1)
varname='P:+1DP' ! P:+1DP
call add2list(varname,tvar,ntrace1)
varname='P:-1DP' ! P:-1DP
call add2list(varname,tvar,ntrace1)
! Get the dependencies for dth/dp (DTHDP)
elseif ( tvar(i).eq.'DTHDP' ) then
varname='T:+1DP' ! T:+1DP
call add2list(varname,tvar,ntrace1)
varname='T:-1DP' ! T:-1DP
call add2list(varname,tvar,ntrace1)
varname='T' ! T
call add2list(varname,tvar,ntrace1)
varname='P:+1DP' ! P:+1DP
call add2list(varname,tvar,ntrace1)
varname='P:-1DP' ! P:-1DP
call add2list(varname,tvar,ntrace1)
varname='P' ! P
call add2list(varname,tvar,ntrace1)
! Get the dependencies for squared Brunt Vaiäläa frequency (NSQ)
elseif ( tvar(i).eq.'NSQ' ) then
varname='DTHDP' ! DTHDP
call add2list(varname,tvar,ntrace1)
varname='TH' ! TH
call add2list(varname,tvar,ntrace1)
varname='RHO' ! RHO
call add2list(varname,tvar,ntrace1)
! Get the dependencies for relative vorticity (RELVORT)
elseif ( tvar(i).eq.'RELVORT' ) then
varname='U' ! U
call add2list(varname,tvar,ntrace1)
varname='DUDY' ! DUDY
call add2list(varname,tvar,ntrace1)
varname='DVDX' ! DVDX
call add2list(varname,tvar,ntrace1)
! Get the dependencies for relative vorticity (ABSVORT)
elseif ( tvar(i).eq.'ABSVORT' ) then
varname='U' ! U
call add2list(varname,tvar,ntrace1)
varname='DUDY' ! DUDY
call add2list(varname,tvar,ntrace1)
varname='DVDX' ! DVDX
call add2list(varname,tvar,ntrace1)
! Get the dependencies for divergence (DIV)
elseif ( tvar(i).eq.'DIV' ) then
varname='V' ! U
call add2list(varname,tvar,ntrace1)
varname='DUDX' ! DUDX
call add2list(varname,tvar,ntrace1)
varname='DVDY' ! DVDY
call add2list(varname,tvar,ntrace1)
! Get the dependencies for deformation (DEF)
elseif ( tvar(i).eq.'DEF' ) then
call add2list(varname,tvar,ntrace1)
varname='DUDX' ! DUDX
call add2list(varname,tvar,ntrace1)
varname='DVDY' ! DVDY
call add2list(varname,tvar,ntrace1)
varname='DUDY' ! DUDY
call add2list(varname,tvar,ntrace1)
varname='DVDX' ! DVDX
call add2list(varname,tvar,ntrace1)
! Get the dependencies for potential vorticity (PV)
elseif ( tvar(i).eq.'PV' ) then
varname='ABSVORT' ! ABSVORT
call add2list(varname,tvar,ntrace1)
varname='DTHDP' ! DTHDP
call add2list(varname,tvar,ntrace1)
varname='DUDP' ! DUDP
call add2list(varname,tvar,ntrace1)
varname='DVDP' ! DVDP
call add2list(varname,tvar,ntrace1)
varname='DTHDX' ! DTHDX
call add2list(varname,tvar,ntrace1)
varname='DTHDY' ! DTHDY
call add2list(varname,tvar,ntrace1)
! Get the dependencies for Richardson number (RI)
elseif ( tvar(i).eq.'RI' ) then
varname='DUDP' ! DUDP
call add2list(varname,tvar,ntrace1)
varname='DVDP' ! DVDP
call add2list(varname,tvar,ntrace1)
varname='NSQ' ! NSQ
call add2list(varname,tvar,ntrace1)
varname='RHO' ! RHO
call add2list(varname,tvar,ntrace1)
! Get the dependencies for Ellrod&Knapp's turbulence index (TI)
elseif ( tvar(i).eq.'TI' ) then
varname='DEF' ! DEF
call add2list(varname,tvar,ntrace1)
varname='DUDP' ! DUDP
call add2list(varname,tvar,ntrace1)
varname='DVDP' ! DVDP
call add2list(varname,tvar,ntrace1)
varname='RHO' ! RHO
call add2list(varname,tvar,ntrace1)
endif
! Exit point for handling additional fields
100 continue
i = i + 1
enddo
! Save the full variable name (including shift specification)
do i=1,ncol
varsint(i) = varsinp(i)
enddo
do i=1,ntrace1
varsint(i+ncol) = tvar(i)
enddo
! Bojan: check that PV and TH are on trajectory
if (intmode .eq. 'clustering') then
pvpos=-1
thpos=-1
do i=1,ncol+ntrace1
if (varsint(i) .eq. 'TH') then
thpos=i
print*,'Clustering: Found TH at position:',thpos
endif
if (varsint(i) .eq. 'PV') then
pvpos=i
print*,'Clustering: Found PV at position:',pvpos
endif
enddo
if (thpos .eq. -1) then
print*,'WARNING (clustering): Did not find TH'
stop
endif
if (pvpos .eq. -1) then
print*,'WARNING (clustering): Did not find PV'
stop
endif
endif
! Bojan
! Split the tracing variables
do i=1,ntrace0
call splitvar(tvar(i),shift_val(i),shift_dir(i) )
enddo
! Split the variable name and set flags
do i=ntrace0+1,ntrace1
! Set the scaling factor
fac(i) = 1.
! Set the base variable name, the shift and the direction
call splitvar(tvar(i),shift_val(i),shift_dir(i) )
! Set the prefix of the file name for additional fields
tfil(i)='*'
do j=1,n_pvars
if ( tvar(i).eq.pvars(j) ) tfil(i)=charp
enddo
do j=1,n_svars
if ( tvar(i).eq.svars(j) ) tfil(i)=chars
enddo
! Set the computational flag
if ( (tvar(i).eq.'P' ).or. &
(tvar(i).eq.'PLAY').or. &
(tvar(i).eq.'PLEV') ) then
compfl(i) = 0
tfil(i) = charp
elseif ( ( tfil(i).eq.charp ).or.( tfil(i).eq.chars ) ) then
compfl(i) = 0
else
compfl(i) = 1
endif
enddo
! Check whether the shift modes are supported
do i=1,ntrace1
if ( ( shift_dir(i).ne.'nil' ).and. &
( shift_dir(i).ne.'DLON' ).and. &
( shift_dir(i).ne.'DLAT' ).and. &
( shift_dir(i).ne.'DP' ).and. &
( shift_dir(i).ne.'HPA' ).and. &
( shift_dir(i).ne.'KM(LON)' ).and. &
( shift_dir(i).ne.'KM(LAT)' ).and. &
( shift_dir(i).ne.'H' ).and. &
( shift_dir(i).ne.'MIN' ).and. &
( shift_dir(i).ne.'INDP' ) ) then
print*,' ERROR: shift mode ',trim(shift_dir(i)), ' not supported'
stop
endif
enddo
! Write status information
print*
print*,'---- COMPLETE TABLE FOR TRACING -------------------------'
print*
do i=1,ntrace1
if ( ( shift_dir(i).ne.'nil' ) ) then
write(*,'(i4,a4,a8,f10.2,a8,3x,a1,i5)') i,' : ',trim(tvar(i)), &
shift_val(i),trim(shift_dir(i)),tfil(i),compfl(i)
else
write(*,'(i4,a4,a8,10x,8x,3x,a1,i5)') &
i,' : ',trim(tvar(i)),tfil(i),compfl(i)
endif
enddo
! --------------------------------------------------------------------
! Prepare the internal and output trajectories
! --------------------------------------------------------------------
! Allocate memory for internal trajectories
allocate(traint(ntra,ntim,ncol+ntrace1),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traint ***'
! Copy input to output trajectory
do i=1,ntra
do j=1,ntim
do k=1,ncol
traint(i,j,k)=trainp(i,j,k)
enddo
enddo
enddo
! Set the flags for ready fields/colums - at begin only read-in fields are ready
do i=1,ncol
fok(i) = 1
enddo
do i=ncol+1,ntrace1
fok(i) = 0
enddo
! --------------------------------------------------------------------
! Trace the fields (fields available on input files)
! --------------------------------------------------------------------
print*
print*,'---- TRACING FROM PRIMARY AND SECONDARY DATA FILES ------'
! Loop over all tracing fields
do i=1,ntrace1
! Skip fields which must be computed (compfl=1), will be handled later
if (compfl(i).ne.0) goto 110
! Write some status information
print*
print*,' Now tracing : ', trim(tvar(i)),shift_val(i),trim(shift_dir(i)),compfl(i),' ',trim(tfil(i))
! Set the flag for ready field/column
fok(ncol+i) = 1
! Reset flags for load manager
iloaded0 = -1
iloaded1 = -1
! Reset the counter for fields outside domain
noutside = 0
err_c1 = 0
err_c2 = 0
err_c3 = 0
! Loop over all times
do j=1,ntim
! Convert trajectory time from hh.mm to fractional time
call hhmm2frac(trainp(1,j,1),tfrac)
! Shift time if requested
if ( shift_dir(i).eq.'H' ) then
tfrac = tfrac + shift_val(i)
elseif ( shift_dir(i).eq.'MIN' ) then
tfrac = tfrac + shift_val(i)/60.
endif
! Get the times which are needed
itime0 = int(abs(tfrac-tstart)/timeinc) + 1
time0 = tstart + fbflag * real(itime0-1) * timeinc
itime1 = itime0 + 1
time1 = time0 + fbflag * timeinc
if ( itime1.gt.numdat ) then
itime1 = itime0
time1 = time0
endif
! Load manager: Check whether itime0 can be copied from itime1
if ( itime0.eq.iloaded1 ) then
f3t0 = f3t1
p3t0 = p3t1
spt0 = spt1
iloaded0 = itime0
endif
! Load manager: Check whether itime1 can be copied from itime0
if ( itime1.eq.iloaded0 ) then
f3t1 = f3t0
p3t1 = p3t0
spt1 = spt0
iloaded1 = itime1
endif
! Load manager: Load first time (tracing variable and grid)
if ( itime0.ne.iloaded0 ) then
filename = tfil(i)//dat(itime0)
call frac2hhmm(time0,tload)
varname = tvar(i)
write(*,'(a23,a20,a3,a5,f7.2)') ' -> loading : ', trim(filename),' ',trim(varname),tload
call input_open (fid,filename)
call input_wind &
(fid,varname,f3t0,tload,stagz,mdv, &
xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid &
(fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny, &
tload,pollon,pollat,p3t0,spt0,nz,ak,bk,stagz, &
timecheck)
call input_close(fid)
iloaded0 = itime0
endif
! Load manager: Load second time (tracing variable and grid)
if ( itime1.ne.iloaded1 ) then
filename = tfil(i)//dat(itime1)
call frac2hhmm(time1,tload)
varname = tvar(i)
write(*,'(a23,a20,a3,a5,f7.2)') ' -> loading : ', trim(filename),' ',trim(varname),tload
call input_open (fid,filename)
call input_wind &
(fid,varname,f3t1,tload,stagz,mdv, &
xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
call input_grid &
(fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny, &
tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz, &
timecheck)
call input_close(fid)
iloaded1 = itime1
endif
! Loop over all trajectories
do k=1,ntra
! Set the horizontal position where to interpolate to
x0 = traint(k,j,2) ! Longitude
y0 = traint(k,j,3) ! Latitude
! Set the vertical position where to interpolate to
if ( nz.gt.1 ) then
p0 = traint(k,j,4) ! Pressure (3D tracing)
else
p0 = 1050. ! Lowest level (2D tracing)
endif
! Set negative pressures to mdv
if (p0.lt.0.) then
f0 = mdv
goto 109
endif
! Set the relative time
call hhmm2frac(traint(k,j,1),tfrac)
reltpos0 = fbflag * (tfrac-time0)/timeinc
! Make adjustments depending on the shift flag
if ( shift_dir(i).eq.'DLON' ) then ! DLON
x0 = x0 + shift_val(i)
elseif ( shift_dir(i).eq.'DLAT' ) then ! DLAT
y0 = y0 + shift_val(i)
elseif ( shift_dir(i).eq.'KM(LON)' ) then ! KM(LON)
x0 = x0 + shift_val(i)/deg2km * 1./cos(y0*pi180)
elseif ( shift_dir(i).eq.'KM(LAT)' ) then ! KM(LAT)
y0 = y0 + shift_val(i)/deg2km
elseif ( shift_dir(i).eq.'HPA' ) then ! HPA
p0 = p0 + shift_val(i)
elseif ( shift_dir(i).eq.'DP' ) then ! DP
call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0, &
p3t0,p3t1,spt0,spt1,3,nx,ny,nz,xmin,ymin,dx,dy,mdv)
pind = pind - shift_val(i)
p0 = int_index4(p3t0,p3t1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
elseif ( shift_dir(i).eq.'INDP' ) then
p0 = int_index4(p3t0,p3t1,nx,ny,nz,xind,yind,shift_val(i),reltpos0,mdv)
endif
! Handle periodic boundaries in zonal direction
if ( (x0.gt.xmax).and.(per.ne.0) ) x0 = x0 - 360.
if ( (x0.lt.xmin).and.(per.ne.0) ) x0 = x0 + 360.
! Handle pole problems for hemispheric data (taken from caltra.f)
if ((hem.eq.1).and.(y0.gt.90.)) then
print*,'WARNING: y0>90 ',y0,' => setting to 180-y0 ',180.-y0
y0=180.-y0
x0=x0+per/2.
endif
if ((hem.eq.1).and.(y0.lt.-90.)) then
print*,'WARNING: y0<-90 ',y0,' => setting to -180-y0 ',-180.-y0
y0=-180.-y0
x0=x0+per/2.
endif
! Get the index where to interpolate (x0,y0,p0)
if ( (abs(x0-mdv).gt.eps).and. (abs(y0-mdv).gt.eps) ) then
call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0, &
p3t0,p3t1,spt0,spt1,3,nx,ny,nz,xmin,ymin,dx,dy,mdv)
else
xind = mdv
yind = mdv
pind = mdv
endif
! Check if point is within grid (keep indices if ok)
if ( (xind.ge.1.).and.(xind.le.real(nx)).and. &
(yind.ge.1.).and.(yind.le.real(ny)).and. &
(pind.ge.1.).and.(pind.le.real(nz)) ) then
xind = xind
yind = yind
pind = pind
! Check if pressure is outside, but rest okay => adjust to lowest or highest level
elseif ( (xind.ge.1.).and.(xind.le.real(nx)).and. (yind.ge.1.).and.(yind.le.real(ny)) ) then ! only vertical problem
if ( pind.gt.nz ) then ! pressure too low, index too high
err_c1 = err_c1 + 1
if ( err_c1.lt.10 ) then
write(*,'(Af5.3A)') ' WARNING: pressure too low (pind = ',pind,') => adjusted to highest level (pind=nz.)'
print*,'(x0,y0,p0)=',x0,y0,p0
pind = real(nz)
elseif ( err_c1.eq.10 ) then
print*,' WARNING: more pressures too low -> adjusted to highest level '
pind = real(nz)
else
pind = real(nz)
endif
elseif (pind.lt.1.) then ! pressure too high, index too low
err_c2 = err_c2 + 1
if ( err_c2.lt.10 ) then
write(*,'(Af5.3A)') ' WARNING: pressure too high (pind = ',pind,') => adjusted to lowest level, (pind=1.)'
print*,'(x0,y0,p0)=',x0,y0,p0
pind = 1.
elseif ( err_c2.eq.10 ) then
print*,' WARNING: more pressures too high -> adjusted to lowest level '
pind = 1.
else
pind = 1.
endif
endif
! Grid point is outside!
else
err_c3 = err_c3 + 1
if ( err_c3.lt.10 ) then
print*,'ERROR: point is outside grid (horizontally)'
print*,' Trajectory # ',k
print*,' Position ',x0,y0,p0
print*,' (xind,yind): ',xind,yind
xind = mdv
yind = mdv
pind = mdv
traint(k,j,2) = mdv
traint(k,j,3) = mdv
traint(k,j,4) = mdv
elseif ( err_c3.eq.10 ) then
print*,'ERROR: more points outside grid (horizontally)'
xind = mdv
yind = mdv
pind = mdv
traint(k,j,2) = mdv
traint(k,j,3) = mdv
traint(k,j,4) = mdv
else
xind = mdv
yind = mdv
pind = mdv
traint(k,j,2) = mdv
traint(k,j,3) = mdv
traint(k,j,4) = mdv
endif
endif
! ------------------------ NEAREST mode -------------------------------
! Interpolate to nearest grid point
if ( intmode.eq.'nearest') then
xind = real( nint(xind) )
yind = real( nint(yind) )
pind = real( nint(pind) )
if ( xind.lt.1. ) xind = 1.
if ( xind.gt.nx ) xind = real(nx)
if ( yind.lt.1. ) yind = 1.
if ( yind.gt.ny ) yind = real(ny)
if ( pind.lt.1. ) pind = 1.
if ( pind.gt.nz ) pind = real(nz)
if ( abs(reltpos0).ge.eps ) then
print*,'ERROR (nearest): reltpos != 0',reltpos0
stop
endif
! interpolate
f0 = int_index4(f3t0,f3t1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
! ------------------------ end NEAREST mode -------------------------------
! ------------------------ CLUSTERING mode ------------------------------- Bojan
elseif (intmode.eq.'clustering') then
if (varname.ne.'LABEL' ) then
print*,'ERROR (clustering): varname is not LABEL'
stop
endif
! Get indices of box around the point
xindb=floor(xind)
xindf=ceiling(xind)
yindb=floor(yind)
yindf=ceiling(yind)
pindb=floor(pind)
pindf=ceiling(pind)
! Make sure all points are within grid
if ( xindb.lt.1 ) xindb = 1
if ( xindf.lt.1 ) xindf = 1
if ( xindb.gt.nx ) xindb = nx
if ( xindf.gt.nx ) xindf = nx
if ( yindb.lt.1 ) yindb = 1
if ( yindf.lt.1 ) yindf = 1
if ( yindb.gt.ny ) yindb = ny
if ( yindf.gt.ny ) yindf = ny
if ( pindb.lt.1 ) pindb = 1
if ( pindf.lt.1 ) pindf = 1
if ( pindb.gt.nz ) pindb = nz
if ( pindf.gt.nz ) pindf = nz
! Shift one point if they are equal
if ( xindb.eq.xindf ) then
if ( xindf.eq.nx ) then
xindb=nx-1
else
xindf=xindb+1
endif
endif
if ( yindb.eq.yindf ) then
if ( yindf.eq.ny ) then
yindb=ny-1
else
yindf=yindb+1
endif
endif
if ( pindb.eq.pindf ) then
if ( pindf.eq.nz ) then
pindb=nz-1
else
pindf=pindb+1
endif
endif
! Give warnings and stop if problems occur
if ( xindb.eq.xindf ) then
print*,'ERROR (clustering): xindb=xindf'
print*,xind,xindb,xindf
stop
endif
if ( yindb.eq.yindf ) then
print*,'ERROR (clustering): yindb=yindf'
print*,yind,yindb,yindf
stop
endif
if ( pindb.eq.pindf ) then
print*,'ERROR (clustering): pindb=pindf'
print*,pind,pindb,pindf
stop
endif
if ( ( xindb.lt.1 ).or.( xindf.gt.nx ) ) then
print*,'ERROR (clustering): xindb/f outside'
print*,xind,xindb,xindf
stop
endif
if ( ( yindb.lt.1 ).or.( yindf.gt.ny ) ) then
print*,'ERROR (clustering): yindb/f outside'
print*,yind,yindb,yindf
stop
endif
if ( ( pindb.lt.1 ).or.( pindf.gt.nz ) ) then
print*,'ERROR (clustering): pindb/f outside'
print*,pind,pindb,pindf
stop
endif
if ( abs(reltpos0).ge.eps ) then
print*,'ERROR (clustering): reltpos != 0',reltpos0
stop
endif
! Get Value in Box
lblcount=(/0,0,0,0,0/)
lbl(1) = f3t0( xindb + nx*(yindb-1) + nx*ny*(pindb-1) )
lbl(2) = f3t0( xindf + nx*(yindb-1) + nx*ny*(pindb-1) )
lbl(3) = f3t0( xindb + nx*(yindf-1) + nx*ny*(pindb-1) )
lbl(4) = f3t0( xindf + nx*(yindf-1) + nx*ny*(pindb-1) )
lbl(5) = f3t0( xindb + nx*(yindb-1) + nx*ny*(pindf-1) )
lbl(6) = f3t0( xindf + nx*(yindb-1) + nx*ny*(pindf-1) )
lbl(7) = f3t0( xindb + nx*(yindf-1) + nx*ny*(pindf-1) )
lbl(8) = f3t0( xindf + nx*(yindf-1) + nx*ny*(pindf-1) )
! Count the number of times every label appears
do lci=1,5
do lcj=1,8
if ( abs(lbl(lcj)-lci).lt.eps ) then
lblcount(lci)=lblcount(lci)+1
endif
enddo
enddo
! Set to -9 to detect if no label was assigned in the end
f0=-9
! Stratosphere (PV)
if ( abs(traint(k,j,pvpos)) .ge. tropo_pv ) then
if ( (lblcount(2).ge.lblcount(3)).and. (lblcount(2).ge.lblcount(5)) ) then
f0=2
elseif ( lblcount(3).ge.lblcount(5) ) then
f0=3
elseif ( lblcount(5).gt.lblcount(3) ) then
f0=5
endif
endif
! Troposphere (PV)
if ( abs(traint(k,j,pvpos)) .lt. tropo_pv ) then
if ( lblcount(1).ge.lblcount(4) ) then
f0=1
elseif ( lblcount(4).gt.lblcount(1) ) then
f0=4
endif
endif
! Stratosphere (TH)
if ( traint(k,j,thpos) .ge. tropo_th ) then
f0=2
endif
if (f0.eq.-9) then
print*,'ERROR (Clustering): No label assigned!'
stop
endif
! ------------------------ end CLUSTERING mode -------------------------------
! ------------------------ CIRCLE modes ------------------------------- Bojan
! elseif (not clustering but one of the possible circle modes)
elseif ( (intmode.eq.'circle_avg') .or. (intmode.eq.'circle_min') .or. (intmode.eq.'circle_max') ) then
! reset arrays for this point
connect=0
stackx=0
stacky=0
circlelon=0
circlelat=0
circlef=0
circlearea=0
! Get indices of one coarse grid point within search radius (nint=round to next integer)
if ( sdis(x0,y0,longrid(nint(xind)),latgrid(nint(yind))) .gt. radius) then
print*,'ERROR (circle): Search radius is too small... (1). r =',radius
print*,'Distance to nint grid point (minimum search radius)=',sdis(x0,y0,longrid(nint(xind)),latgrid(nint(yind)))
stop
endif
! Initialize stack with nint(xind),nint(yind)
kst=0 ! counts the number of points in circle
stackx(1)=nint(xind)
stacky(1)=nint(yind)
sp=1 ! stack counter
do while (sp.ne.0)
! Get an element from stack
ist=stackx(sp)
jst=stacky(sp)
sp=sp-1
! Get distance from reference point
dist=sdis(x0,y0,longrid(ist),latgrid(jst))
! Check whether distance is smaller than search radius: connected
if (dist.lt.radius) then
! Increase total stack index
kst=kst+1
circlelon(kst)=longrid(ist)
circlelat(kst)=latgrid(jst)
! Interpolate field to position of point (interpolation in time!)
circlef(kst) = int_index4(f3t0,f3t1,nx,ny,nz,real(ist),real(jst),pind,reltpos0,mdv)
! Calculate area of point (for circle_avg mode only)
if ( intmode .eq. 'circle_avg' ) then
circlearea(kst) = pir/(nx-1)*(sin(pi180*abs(circlelat(kst)))-sin(pi180*(abs(circlelat(kst))-dy)))
endif
! Mark this point as visited
connect(ist,jst)=1
! Get coordinates of neighbouring points and implement periodicity
mr=ist+1
if (mr.gt.nx) mr=1
ml=ist-1
if (ml.lt.1) ml=nx
nu=jst+1
if (nu.gt.ny) nu=ny
nd=jst-1
if (nd.lt.1) nd=1
! Update stack with neighbouring points
if (connect(mr,jst).ne. 1) then
connect(mr,jst)=1
sp=sp+1
stackx(sp)=mr
stacky(sp)=jst
endif
if (connect(ml,jst).ne. 1) then
connect(ml,jst)=1
sp=sp+1
stackx(sp)=ml
stacky(sp)=jst
endif
if (connect(ist,nd).ne. 1) then
connect(ist,nd)=1
sp=sp+1
stackx(sp)=ist
stacky(sp)=nd
endif
if (connect(ist,nu).ne. 1) then
connect(ist,nu)=1
sp=sp+1
stackx(sp)=ist
stacky(sp)=nu
endif
endif ! endif radius is smaller => end of updating stack
end do ! end working on stack
if (kst.ge.1) then
! Choose output depending on intmode
if ( intmode .eq. 'circle_avg' ) then
! calculate area-weighted average of f in circle
circlesum=0.
do l=1,kst
circlesum=circlesum+circlef(l)*circlearea(l)
enddo
circleavg=circlesum/sum(circlearea(1:kst))
!print*,'area-weighted average of f in circle=',circleavg
f0=circleavg
elseif ( intmode .eq. 'circle_min' ) then
! calculate minimum in circle
circlemin=circlef(1)
do l=1,kst
if (circlef(l) .lt. circlemin) then
circlemin=circlef(l)
endif
enddo
!print*,'minimum of f in circle=',circlemin
f0=circlemin
elseif ( intmode .eq. 'circle_max' ) then
! calculate maximum in circle
circlemax=circlef(1)
do l=1,kst
if (circlef(l) .gt. circlemax) then
circlemax=circlef(l)
endif
enddo
!print*,'maximum of f in circle=',circlemax
f0=circlemax
else
print*,'ERROR (circle): intmode not valid!'
stop
endif
else
print*,'ERROR (circle): Search radius is too small... (2). r =',radius
stop
endif
! ------------------------ end CIRCLE modes -------------------------------
! ------------------------ NORMAL mode -------------------------------
else ! not clustering nor circle: NORMAL mode
! Check if point is within grid
! if ( (xind.ge.1.).and.(xind.le.real(nx)).and. &
! (yind.ge.1.).and.(yind.le.real(ny)).and. &
! (pind.ge.1.).and.(pind.le.real(nz)) ) then
!
! Do the interpolation: everthing is ok
f0 = int_index4(f3t0,f3t1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
! ! Check if pressure is outside, but rest okay: adjust to lowest or highest level
! elseif ( (xind.ge.1.).and.(xind.le.real(nx)).and. (yind.ge.1.).and.(yind.le.real(ny)) ) then ! only vertical problem
! if ( pind.gt.nz ) then ! pressure too low, index too high
! pind = real(nz)
! print*,' Warning: pressure too low -> adjusted to highest level, pind=nz.'
! print*,'(x0,y0,p0)=',x0,y0,p0
! elseif (pind.lt.1.) then ! pressure too high, index too low
! pind = 1.
! print*,' Warning: pressure too high -> adjusted to lowest level, pind=1.'
! print*,'(x0,y0,p0)=',x0,y0,p0
! endif
! f0 = int_index4(f3t0,f3t1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
! ! Less than 10 outside
! elseif (noutside.lt.10) then
! print*,' ',trim(tvar(i)),' @ ',x0,y0,p0,'outside'
! f0 = mdv
! noutside = noutside + 1
!
! ! More than 10 outside
! elseif (noutside.eq.10) then
! print*,' ...more than 10 outside...'
! f0 = mdv
! noutside = noutside + 1
! ! Else (not everything okay and also not 'tolerated cases') set to missing data
! else
! f0 = mdv
! endif
! ------------------------ end NORMAL mode -------------------------------
endif ! end if nearest case
! Exit for loop over all trajectories and times -save interpolated value
109 continue
! Save the new field
if ( abs(f0-mdv).gt.eps) then
traint(k,j,ncol+i) = f0
else
traint(k,j,ncol+i) = mdv
endif
enddo ! end loop over all trajectories
enddo ! end loop over all times
! Exit point for loop over all tracing variables
110 continue
enddo ! end loop over all variables
! --------------------------------------------------------------------
! Calculate additional fields along the trajectories
! --------------------------------------------------------------------
print*
print*,'---- CALCULATE ADDITIONAL FIELDS FROM TRAJECTORY TABLE --'
! Loop over all tracing fields
do i=ntrace1,1,-1
! Skip fields which must not be computed (compfl=0)
if (compfl(i).eq.0) goto 120
! Write some status information
print*
write(*,'(a10,f10.2,a5,i3,3x,a2)') &
trim(tvar(i)),shift_val(i),trim(shift_dir(i)),compfl(i),trim(tfil(i))
! Loop over trajectories and times
do j=1,ntra
do k=1,ntim
! Potential temperature (TH)
if ( varsint(i+ncol).eq.'TH' ) then
varname='T'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='p'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_TH (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Density (RHO)
elseif ( varsint(i+ncol).eq.'RHO' ) then
varname='T'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='p'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_RHO (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Relative humidity (RH)
elseif ( varsint(i+ncol).eq.'RH' ) then
varname='T'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='p'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='Q'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_RH (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Equivalent potential temperature (THE)
elseif ( varsint(i+ncol).eq.'THE' ) then
varname='T'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='p'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='Q'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_THE (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Latent heating rate (LHR)
elseif ( varsint(i+ncol).eq.'LHR' ) then
varname='T'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='p'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='Q'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='OMEGA'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
varname='RH'
call list2ind (ind5,varname,varsint,fok,ncol+ntrace1)
call calc_LHR (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4),traint(j,k,ind5) )
! Wind speed (VEL)
elseif ( varsint(i+ncol).eq.'VEL' ) then
varname='U'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='V'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_VEL (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Wind direction (DIR)
elseif ( varsint(i+ncol).eq.'DIR' ) then
varname='U'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='V'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_DIR (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Zonal gradient of U (DUDX)
elseif ( varsint(i+ncol).eq.'DUDX' ) then
varname='U:+1DLON'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='U:-1DLON'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_DUDX (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Zonal gradient of V (DVDX)
elseif ( varsint(i+ncol).eq.'DVDX' ) then
varname='V:+1DLON'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='V:-1DLON'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_DVDX (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Zonal gradient of T (DTDX)
elseif ( varsint(i+ncol).eq.'DVDX' ) then
varname='T:+1DLON'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DLON'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_DTDX (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Zonal gradient of TH (DTHDX)
elseif ( varsint(i+ncol).eq.'DTHDX' ) then
varname='T:+1DLON'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DLON'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DTHDX (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Meridional gradient of U (DUDY)
elseif ( varsint(i+ncol).eq.'DUDY' ) then
varname='U:+1DLAT'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='U:-1DLAT'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_DUDY (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Meridional gradient of V (DVDY)
elseif ( varsint(i+ncol).eq.'DVDY' ) then
varname='V:+1DLAT'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='V:-1DLAT'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_DVDY (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Meridional gradient of T (DTDY)
elseif ( varsint(i+ncol).eq.'DTDY' ) then
varname='T:+1DLAT'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DLAT'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_DTDY (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2) )
! Meridional gradient of TH (DTHDY)
elseif ( varsint(i+ncol).eq.'DTHDY' ) then
varname='T:+1DLAT'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DLAT'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_DTDY (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3) )
! Vertical wind shear DU/DP (DUDP)
elseif ( varsint(i+ncol).eq.'DUDP' ) then
varname='U:+1DP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='U:-1DP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P:+1DP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='P:-1DP'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DUDP (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Vertical wind shear DV/DP (DVDP)
elseif ( varsint(i+ncol).eq.'DVDP' ) then
varname='V:+1DP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='V:-1DP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P:+1DP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='P:-1DP'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DVDP (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Vertical derivative of T (DTDP)
elseif ( varsint(i+ncol).eq.'DTDP' ) then
varname='T:+1DP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P:+1DP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='P:-1DP'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DTDP (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Vertical derivative of TH (DTHDP)
elseif ( varsint(i+ncol).eq.'DTHDP' ) then
varname='T:+1DP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='T:-1DP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='P:+1DP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='P:-1DP'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
varname='P'
call list2ind (ind5,varname,varsint,fok,ncol+ntrace1)
varname='T'
call list2ind (ind6,varname,varsint,fok,ncol+ntrace1)
call calc_DTHDP (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4),traint(j,k,ind5),traint(j,k,ind6) )
! Squared Brunt-Vaisäla frequency (NSQ)
elseif ( varsint(i+ncol).eq.'NSQ' ) then
varname='DTHDP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='TH'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='RHO'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
call calc_NSQ (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3))
! Relative vorticity (RELVORT)
elseif ( varsint(i+ncol).eq.'RELVORT' ) then
varname='DUDY'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DVDX'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='U'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_RELVORT (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4))
! Absolute vorticity (ABSVORT)
elseif ( varsint(i+ncol).eq.'ABSVORT' ) then
varname='DUDY'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DVDX'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='U'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_ABSVORT (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4))
! Divergence (DIV)
elseif ( varsint(i+ncol).eq.'DIV' ) then
varname='DUDX'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DVDY'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='V'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DIV (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4))
! Deformation (DEF)
elseif ( varsint(i+ncol).eq.'DEF' ) then
varname='DUDX'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DVDX'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='DUDY'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='DVDY'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_DEF (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4))
! Potential Vorticity (PV)
elseif ( varsint(i+ncol).eq.'PV' ) then
varname='ABSVORT'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DTHDP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='DUDP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='DVDP'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
varname='DTHDX'
call list2ind (ind5,varname,varsint,fok,ncol+ntrace1)
varname='DTHDY'
call list2ind (ind6,varname,varsint,fok,ncol+ntrace1)
call calc_PV (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4),traint(j,k,ind5),traint(j,k,ind6) )
! Richardson number (RI)
elseif ( varsint(i+ncol).eq.'RI' ) then
varname='DUDP'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DVDP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='NSQ'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='RHO'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_RI (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Ellrod and Knapp's turbulence idicator (TI)
elseif ( varsint(i+ncol).eq.'TI' ) then
varname='DEF'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='DUDP'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
varname='DVDP'
call list2ind (ind3,varname,varsint,fok,ncol+ntrace1)
varname='RHO'
call list2ind (ind4,varname,varsint,fok,ncol+ntrace1)
call calc_TI (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,k,ind3),traint(j,k,ind4) )
! Spherical distance from starting position (DIST0)
elseif ( varsint(i+ncol).eq.'DIST0' ) then
varname='lon'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
call calc_DIST0 (traint(j,k,ncol+i), traint(j,k,ind1), &
traint(j,k,ind2),traint(j,1,ind1),traint(j,1,ind2) )
! Spherical distance length of trajectory (DIST)
elseif ( varsint(i+ncol).eq.'DIST' ) then
varname='lon'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
if ( k.eq.1 ) then
traint(j,k,ncol+i) = 0.
else
call calc_DIST0 (delta, traint(j,k ,ind1), &
traint(j,k ,ind2),traint(j,k-1,ind1),traint(j,k-1,ind2) )
traint(j,k,ncol+i) = traint(j,k-1,ncol+i) + delta
endif
! Heading of the trajectory (HEAD)
elseif ( varsint(i+ncol).eq.'HEAD' ) then
varname='lon'
call list2ind (ind1,varname,varsint,fok,ncol+ntrace1)
varname='lat'
call list2ind (ind2,varname,varsint,fok,ncol+ntrace1)
if (k.eq.ntim) then
traint(j,k,ncol+i) = mdv
else
call calc_HEAD (traint(j,k,ncol+i), &
traint(j,k ,ind1),traint(j,k ,ind2),traint(j,k+1,ind1),traint(j,k+1,ind2) )
endif
! Invalid tracing variable
else
print*,' ERROR: invalid tracing variable ', trim(varsint(i+ncol))
stop
endif
! End loop over all trajectories and times
enddo
enddo
! Set the flag for a ready field/column
fok(ncol+i) = 1
! Exit point for loop over all tracing fields
120 continue
enddo
! --------------------------------------------------------------------
! Write output to output trajectory file
! --------------------------------------------------------------------
! Write status information
print*
print*,'---- WRITE OUTPUT TRAJECTORIES --------------------------'
print*
! Allocate memory for internal trajectories
allocate(traout(ntra,ntim,ncol+ntrace0),stat=stat)
if (stat.ne.0) print*,'*** error allocating array traout ***'
! Copy input to output trajectory (apply scaling of output)
do i=1,ntra
do j=1,ntim
do k=1,ncol+ntrace0
if ( k.le.ncol ) then
traout(i,j,k) = traint(i,j,k)
elseif ( abs(traint(i,j,k)-mdv).gt.eps ) then
traout(i,j,k) = fac(k-ncol) * traint(i,j,k)
else
traout(i,j,k) = mdv
endif
enddo
enddo
enddo
! Set the variable names for output trajectory
do i=1,ncol+ntrace0
varsout(i) = varsint(i)
enddo
! Write trajectories
call wopen_tra(fod,outfile,ntra,ntim,ncol+ntrace0, &
reftime,varsout,outmode)
call write_tra(fod,traout ,ntra,ntim,ncol+ntrace0,outmode)
call close_tra(fod,outmode)
! Write some status information, and end of program message
print*
print*,'---- STATUS INFORMATION --------------------------------'
print*
print*,' ok'
print*
print*,' *** END OF PROGRAM TRACE ***'
print*,'========================================================='
end program trace
! ******************************************************************
! * SUBROUTINE SECTION *
! ******************************************************************
! ------------------------------------------------------------------
! Add a variable to the list if not yet included in this list
! ------------------------------------------------------------------
subroutine add2list (varname,list,nlist)
implicit none
! Declaration of subroutine parameters
character(len=80) :: varname
character(len=80) :: list(200)
integer :: nlist
! Auxiliray variables
integer :: i,j
integer :: isok
! Expand the list, if necessary
isok = 0
do i=1,nlist
if ( list(i).eq.varname ) isok = 1
enddo
if ( isok.eq.0 ) then
nlist = nlist + 1
list(nlist) = varname
endif
! Check for too large number of fields
if ( nlist.ge.200) then
print*,' ERROR: too many additional fields for tracing ...'
stop
endif
end subroutine add2list
! ------------------------------------------------------------------
! Get the index of a variable in the list
! ------------------------------------------------------------------
subroutine list2ind (ind,varname,list,fok,nlist)
implicit none
! Declaration of subroutine parameters
integer :: ind
character(len=80) :: varname
character(len=80) :: list(200)
integer :: fok(200)
integer :: nlist
! Auxiliray variables
integer :: i,j
integer :: isok
! Get the index - error message if not found
ind = 0
do i=1,nlist
if ( varname.eq.list(i) ) then
ind = i
goto 100
endif
enddo
if ( ind.eq.0) then
print*
print*,' ERROR: cannot find ',trim(varname),' in list ...'
do i=1,nlist
print*,i,trim(list(i))
enddo
print*
stop
endif
! Exit point
100 continue
! Check whether the field/column is ready
if ( fok(ind).eq.0 ) then
print*
print*,' ERROR: unresolved dependence : ',trim(list(ind))
print*
stop
endif
end subroutine list2ind
! ------------------------------------------------------------------
! Split the variable name into name, shift and direction
! ------------------------------------------------------------------
subroutine splitvar (tvar,shift_val,shift_dir)
implicit none
! Declaration of subroutine parameters
character(len=80) :: tvar
real :: shift_val
character(len=80) :: shift_dir
! Auxiliary variables
integer :: i,j
integer :: icolon,inumber
character(len=80) :: name
character :: ch
! Save variable name
name = tvar
! Search for colon
icolon=0
do i=1,80
if ( (name(i:i).eq.':').and.(icolon.ne.0) ) goto 100
if ( (name(i:i).eq.':').and.(icolon.eq.0) ) icolon=i
enddo
! If there is a colon, split the variable name
if ( icolon.ne.0 ) then
tvar = name(1:(icolon-1))
do i=icolon+1,80
ch = name(i:i)
if ( ( ch.ne.'0' ).and. ( ch.ne.'1' ).and.( ch.ne.'2' ).and. &
( ch.ne.'3' ).and. ( ch.ne.'4' ).and.( ch.ne.'5' ).and. &
( ch.ne.'6' ).and. ( ch.ne.'7' ).and.( ch.ne.'8' ).and. &
( ch.ne.'9' ).and. ( ch.ne.'+' ).and.( ch.ne.'-' ).and. &
( ch.ne.'.' ).and. ( ch.ne.' ' ) ) then
inumber = i
exit
endif
enddo
read(name( (icolon+1):(inumber-1) ),*) shift_val
shift_dir = name(inumber:80)
else
shift_dir = 'nil'
shift_val = 0.
endif
return
! Error handling
100 continue
print*,' ERROR: cannot split variable name ',trim(tvar)
stop
end subroutine splitvar

/tags/1.0/trace/trace.make
0,0 → 1,8
F77 = ${FORTRAN}
FFLAGS = -O
OBJS = ${LAGRANTO}/lib/times.a ${LAGRANTO}/lib/iotra.a ${LAGRANTO}/lib/ioinp.a ${LAGRANTO}/lib/inter.a ${LAGRANTO}/lib/libcdfio.a ${LAGRANTO}/lib/libcdfplus.a
INCS = ${NETCDF_INC}
LIBS = ${NETCDF_LIB}
trace: $(OBJS)
${F77} -o trace trace.f90 calvar.f $(OBJS) ${INCS} $(LIBS)

/tags/1.0/trace/trace.sh
0,0 → 1,616
#!/bin/csh
# ---------------------------------------------------------------------
# Usage, parameter settings
# ---------------------------------------------------------------------
# Set Lagranto
set LAGRANTO = ${LAGRANTOBASE}.${MODEL}/
# Write usage information
if ( (${#argv} == 0) | (${#argv} < 2) ) then
echo
${LAGRANTO}/bin/lagrantohelp trace short
echo
exit 0
endif
# Write title
echo
echo '========================================================='
echo ' *** START OF PREPROCESSOR TRACE *** '
echo
# Get the arguments
set inpfile = $1
set outfile = $2
# Set base directories (run+prog)
set cdfdir=${PWD}
set tradir=${PWD}
# Set program paths and filenames
set parfile = ${tradir}/trace.param
set prog = ${LAGRANTO}/trace/trace
# Set the prefix of the primary and secondary data files
set charp = 'P'
set chars = 'S'
echo '---- DIRECTORIES AND PROGRAMS ---------------------------'
echo
echo "CDF directory : ${cdfdir}"
echo "TRA directory : ${tradir}"
echo "PROGRAM TRACE : ${prog}"
echo "PARAMETER file : ${parfile}"
echo
# ---------------------------------------------------------------------
# Set optional flags
# ---------------------------------------------------------------------
echo '---- OPTIONAL FLAGS -------------------------------------'
echo
# Set some default values ("nil" must be set according to input files)
set flag_i = "nil"
set flag_v = "tracevars"
set flag_f = "nil"
set tvfile = 'tracevars'
set changet = 'false'
set noclean = 'false'
set timecheck = 'no'
set intmode = 'normal'
set radius = '0'
set tropo_pv = '2'
set tropo_th = '380'
# Set flag for consistency
set isok = 1
while ( $#argv > 0 )
switch ( $argv[1] )
case -i
set flag_i=$argv[2]
echo "Flag '-i' -> ${flag_i} (user defined)"
shift;
breaksw
case -v
set flag_v="-v"
set tvfile=$argv[2]
echo "Flag '-v' -> ${tvfile} (user defined)"
shift;
if ( $isok == 2 ) set isok = 0
if ( $isok == 1 ) set isok = 2
breaksw
case -f
set flag_f="-f"
set tvfile="tracevars.tmp"
shift;
set tvar="$argv[1]"
shift;
set tscale="$argv[1]"
echo "Flag '-f' -> ${tvar} ${tscale} (user defined)"
if ( $isok == 2 ) set isok = 0
if ( $isok == 1 ) set isok = 2
breaksw
case -changet
set changet = 'true'
echo "changet -> true (user defined)"
breaksw
case -noclean
set noclean = 'true'
echo "noclean -> true (user defined)"
breaksw
case -timecheck
set timecheck = 'yes'
echo "timecheck -> yes (user defined)"
breaksw
case -nearest
set intmode = 'nearest'
echo "intmode -> nearest (user defined)"
breaksw
case -clustering
set intmode = 'clustering'
echo "intmode -> clustering (user defined)"
shift;
if ( "$1" == "" ) then
echo "ERROR (clustering): specify tropopause PV [pvu] and TH [K]! Example: -clustering 2 380"
exit
else
set tropo_pv = $1
endif
shift;
if ( "$1" == "" ) then
echo "ERROR (clustering): specify tropopause PV [pvu] and TH [K]! Example: -clustering 2 380"
exit
else
set tropo_th = $1
echo 'intmode -> clustering tropo_pv = ' ${tropo_pv} 'pvu and tropo_th = ' ${tropo_th} 'K'
endif
breaksw
case -circle_avg
set intmode = 'circle_avg'
echo "intmode -> circle_avg (user defined)"
shift;
if ( "$1" == "" ) then
echo "ERROR (circle_avg): specify radius in circle mode (km)! Example: -circle_avg 500"
exit
else
set radius = $1
echo 'intmode -> circle_avg radius =' ${radius} 'km'
endif
breaksw
case -circle_min
set intmode = 'circle_min'
echo "intmode -> circle_min (user defined)"
shift;
if ( "$1" == "" ) then
echo "ERROR (circle_min): specify radius in circle mode (km)! Example: -circle_min 400"
exit
else
set radius = $1
echo 'intmode -> circle_min radius =' ${radius} 'km'
endif
breaksw
case -circle_max
set intmode = 'circle_max'
echo "intmode -> circle_max (user defined)"
shift;
if ( "$1" == "" ) then
echo "ERROR (circle_max): specify radius in circle mode (km)! Example: -circle_max 600"
exit
else
set radius = $1
echo 'intmode -> circle_max radius =' ${radius} 'km'
endif
breaksw
endsw
shift;
end
# No change of times necessary if no check requested
if ( "${timecheck}" == "no" ) then
set changet = 'false'
endif
# Check consitency of arguments
if ( $isok == 0 ) then
echo
echo " ERROR: Use either option '-v' or '-f', but not both..."
exit 1
endif
# ---------------------------------------------------------------------
# Handle the input trajectory file
# ---------------------------------------------------------------------
echo
echo '---- TIME RANGE -----------------------------------------'
echo
# Check whether the input file can be found
if ( ! -f ${inpfile} ) then
echo " ERROR : Input file ${inpfile} is missing"
exit 1
endif
# Get the start, end and reference date for the tracing
set startdate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} startdate`
set enddate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} enddate`
set refdate = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} refdate`
set ntra = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntra`
set ntim = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ntim`
set ncol = `${LAGRANTO}/goodies/trainfo.sh ${inpfile} ncol`
# Check format of start and end date - must be the same
set ns=`echo $startdate | sed -e 's/_[0-9]*//' | wc -c`
set ne=`echo $enddate | sed -e 's/_[0-9]*//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( $ns != 9 ) then
echo " ERROR: Date format must be yyyymmdd ***"
exit 1
endif
set ns=`echo $startdate | sed -e 's/[0-9]*_//' | wc -c`
set ne=`echo $enddate | sed -e 's/[0-9]*_//' | wc -c`
if ( $ns != $ne ) then
echo " ERROR: start and end date must be in the same format ***"
exit 1
endif
if ( ( $ns != 5 ) & ( $ns != 3 ) ) then
echo " ERROR: Time format must be hh(mm) ***"
exit 1
endif
# Split the start and end date into <yymmdd_hh and mm>
set startdate_ymdh = `echo $startdate | cut -c 1-11`
set startdate_min = `echo $startdate | cut -c 12-13`
if ( $startdate_min == "" ) set startdate_min = 00
set enddate_ymdh = `echo $enddate | cut -c 1-11`
set enddate_min = `echo $enddate | cut -c 12-13`
if ( $enddate_min == "" ) set enddate_min = 00
# Get the time difference between <start_ymdh> and <end_ymdh> date
# Decide whether trajectoriesare forward or backward
set timediff_hh = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${startdate_ymdh}`
if ( $timediff_hh == 0 ) then
if ( $enddate_min > $startdate_min ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
endif
else if ( $timediff_hh > 0 ) then
set direction = f
set idir = 1
else
set direction = b
set idir = -1
@ timediff_hh = $idir * $timediff_hh
endif
# Get also minutes for time difference, if <start_min> or <end_min> != 0
set timediff_mm=
if ( $startdate_min != 00 || $enddate_min != 00 ) then
@ min = ( $enddate_min - $startdate_min )
if ( $min == 0 ) then
set timediff_mm=
else if ( $min > 0 ) then
if ( $idir == 1 ) then
set timediff_mm=$min
else
@ timediff_hh --
@ timediff_mm = 60 - $min
endif
else
if ( $idir == 1 ) then
@ timediff_hh --
@ timediff_mm = 60 + $min
else
@ timediff_mm = 0 - $min
endif
endif
endif
# Write status information
echo "Time range : ${startdate} -> ${enddate}"
if ( ${timediff_mm} != "" ) then
echo "Time difference : ${timediff_hh} h ${timediff_mm} min"
else
echo "Time difference : ${timediff_hh} h"
endif
echo "Direction : ${direction} (${idir})"
# ---------------------------------------------------------------------
# Check availability of input data
# ---------------------------------------------------------------------
echo
echo '---- INPUT FILES ----------------------------------------'
echo
# Take the time increment from flag list ('nil', if not defined)
set timeinc = ${flag_i}
# Find a first data file (if possible corresponding to start/end date
# If starttime is not a data time, take the first file in the direectory
if ( $direction == "f" ) then
set file=${charp}${startdate_ymdh}
else
set file=${charp}${enddate_ymdh}
endif
if ( ! -f $file ) then
set file=`ls ${charp}[0-9_]*[0-9] | head -1 | sed -e 's/@//'`
endif
# Determine timeinc (the time difference in hours between two data file)
# if not already defined with option -i
if ( ${timeinc} == "nil" ) then
set date1=`echo $file | cut -c 2-12`
set n=`ls ${charp}[0-9_]*[0-9] | grep -n $date1 | awk -F: '{print $1}'`
@ n ++
set date2=`ls ${charp}[0-9_]*[0-9] | head -$n | tail -1 | cut -c 2-12`
set timeinc=`${LAGRANTO}/goodies/gettidiff $date2 $date1`
endif
if ( $timeinc == 0 ) then
echo " ERROR: cannot set the time increment between input files ***"
exit 1
endif
# Search the first file to use: We step through all P files and see whether they are
# good P files. Let's first do the test for the first data file found. If it's ok, we
# take it; if not, we step through all P files and find the good one
set flag=0
set td=
set date = `echo $file | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
foreach i ( ${charp}????????_?? )
set date = `echo $i | cut -c 2-12`
set td1 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
set td2 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
if (( $td1 < $timeinc || $td2 < $timeinc ) && ( $td1 >= 0 || $td2 >= 0 )) then
set datfiles=$date
if ( $td1 < $timeinc ) set td=$td1
if ( $td2 < $timeinc ) set td=$td2
if ( ( $startdate_min > 0 ) || ( $enddate_min > 0 ) ) @ td ++
goto label2
endif
end
# if no P/T-files are available for the specified time period, then $td is
# still undefined
if ( $td == "" ) then
echo " ERROR: no data files available for the specified time period"
exit 1
endif
# Everything is fine so far: proceed
label2:
# Check whether first date is ok - before or at needed dates
if ( $direction == "f" ) then
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${startdate_ymdh} ${date}`
else
set tdiff0 = `${LAGRANTO}/goodies/gettidiff ${enddate_ymdh} ${date}`
endif
if ( $tdiff0 < 0 ) then
echo " ERROR: data files missing for the specified time period"
exit 1
endif
# Calculate the number of further files
@ num = ( $timediff_hh + $td ) / $timeinc + 1
@ dum1 = ( $num - 1 ) * $timeinc
@ dum2 = $timediff_hh + $td
if ( $dum1 != $dum2 ) @ num ++
# Get a list of all needed files
set numfiles=$num
set sfiles=1
while ( $num > 1 )
set date=`${LAGRANTO}/goodies/newtime $date $timeinc`
if ( ! -f ${charp}${date} ) then
echo " ERROR: file with primary data is missing for $date"
exit 1
else if ( ! -f ${chars}${date} ) then
set sfiles=0
set datfiles=`echo $datfiles $date`
else
set datfiles=`echo $datfiles $date`
endif
@ num --
end
# Calculate the start and the end time relative to the first datfile
if ( $direction == f ) then
set tstart = `${LAGRANTO}/goodies/gettidiff $startdate $datfiles[1]`
set tend = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $enddate`
else
set tstart = `${LAGRANTO}/goodies/gettidiff $datfiles[$numfiles] $startdate`
set tend = `${LAGRANTO}/goodies/gettidiff $enddate $datfiles[1]`
endif
# Write some status information
echo "Primary file prefix : ${charp}"
echo "Secondary file prefix : ${chars}"
echo "Time increment for input files : ${timeinc}"
echo "# input files : ${numfiles}"
echo "First input file : $datfiles[1] "
echo "Last input file : $datfiles[$numfiles] "
echo "${charp} files availability : 1"
echo "${chars} files availability : ${sfiles}"
if ( $direction == f ) then
echo "Start time relative to first file : $datfiles[1] + ${tstart} "
echo "End time relative to last file : $datfiles[$numfiles] - ${tend} "
else
echo "Start time relative to last file : $datfiles[$numfiles] - ${tstart} "
echo "End time relative to first file : $datfiles[1] + ${tend} "
endif
# ---------------------------------------------------------------------
# Check availability of input data
# ---------------------------------------------------------------------
echo
echo '---- TRACEVAR FILE --------------------------------------'
echo
# If "-f" option is used, create a temporary tracevar file
if ( "${flag_f}" == "-f" ) then
# Preset values for <compfl> and <tprefix>
set tcompfl=1
set tprefix='P'
# Check availability on P file
foreach var ( `${LAGRANTO}/goodies/getvars ${charp}$datfiles[1]` )
if ( "${var}" == "${tvar}" ) then
set tcompfl=0
set tprefix="P"
endif
end
# Check availability on S file
if ( ${sfiles} == 1 ) then
foreach var ( `${LAGRANTO}/goodies/getvars ${chars}$datfiles[1]` )
if ( "${var}" == "${tvar}" ) then
set tcompfl=0
set tprefix="S"
endif
end
endif
# Write the temporary <tracevars> file
echo "${tvar} ${tscale} ${tcompfl} ${tprefix}" >! ${tvfile}
echo "Temporary tracervar file <${tvfile}> created"
echo
endif
# Check if tracevars-file exists
if ( ! -f $tvfile ) then
echo " ERROR: file $tvfile was not found ***"
exit 1
endif
# check if the variables contained in the tracevars-file are available in the
# data file and check also if there are no empty lines in the tracevars-file
set nlines = `cat $tvfile | wc -l`
set vars = `cat $tvfile | awk '{print $1}'`
set nvars = `echo $vars | wc -w`
if ( $nlines != $nvars ) then
echo " ERROR: tracevars-files must not contain empty lines ***"
exit 1
endif
set calf=`cat $tvfile | awk '{print $3}'`
set tfil=`cat $tvfile | awk '{print $4}'`
# Write some status information
cat ${tvfile}
echo
echo "# Number of tracing variables : ${nlines}"
echo "Fields are read from following files : ${tfil}"
# Loop over all variables - check availability
foreach v ( $vars )
if ( $calf[1] == 0 ) then
set v0 = `echo $v | awk 'BEGIN {FS = ":"}; {print $1}'`
set flag=`${LAGRANTO}/goodies/getvars $tfil[1]$datfiles[1] | grep " $v0 " | wc -l`
set iscomment=`echo $v0 | cut -c 1`
if ( "${iscomment}" != "#" ) then
if ( $flag == 0 ) then
echo " ERROR: variable $v listed in $tvfile is not on the $tfil[1]-files ***"
exit 1
endif
endif
endif
shift calf
shift tfil
end
set ntrace=${nlines}
# ---------------------------------------------------------------------
# Prepare input file for trace and run it
# ---------------------------------------------------------------------
# Set times relative to the reference date
if ( "${changet}" == "true" ) then
echo
echo '---- CHANGE TIMES ON DATA FILES ------------------------'
echo
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${charp}${i}
end
if ( ${sfiles} == 1 ) then
foreach i ( $datfiles )
${LAGRANTO}/goodies/changet.sh ${refdate} ${chars}${i}
end
endif
endif
# ---------------------------------------------------------------------
# Prepare input file for caltra and run it
# ---------------------------------------------------------------------
# Write parameter file
\rm -f ${parfile}
touch ${parfile}
echo $inpfile >> $parfile
echo $outfile >> $parfile
echo $startdate >> $parfile
echo $enddate >> $parfile
echo $idir >> $parfile
echo $numfiles >> $parfile
foreach i ( $datfiles )
echo $i >> $parfile
end
echo $timeinc >> $parfile
echo $tstart >> $parfile
echo $tend >> $parfile
echo $ntra >> $parfile
echo $ntim >> $parfile
echo $ncol >> $parfile
echo $ntrace >> $parfile
cat ${tvfile} >> $parfile
${LAGRANTO}/goodies/getvars ${charp}$datfiles[1] | wc -l >> $parfile
${LAGRANTO}/goodies/getvars ${charp}$datfiles[1] >> $parfile
if ( $sfiles == 1 ) then
${LAGRANTO}/goodies/getvars ${chars}$datfiles[1] | wc -l >> $parfile
${LAGRANTO}/goodies/getvars ${chars}$datfiles[1] >> $parfile
else
echo 0 >> $parfile
endif
echo \"${timecheck}\" >> $parfile
echo \"${intmode}\" >> $parfile
echo ${radius} >> $parfile # Bojan circle mode
echo ${tropo_pv} >> $parfile # Bojan clustering mode
echo ${tropo_th} >> $parfile # Bojan clustering mode
# Finish the preprocessor
echo
echo ' *** END OF PREPROCESSOR TRACE *** '
echo '========================================================='
echo
# Run trace
${prog}
if ( "${status}" != "0" ) then
echo "ERROR: Program <trace> failed"
exit 1
endif
# ---------------------------------------------------------------------
# Final tasks (make clean)
# ---------------------------------------------------------------------
finish:
if ( "${noclean}" == "false" ) then
\rm -f ${parfile}
endif
exit 0
Property changes:
Added: svn:executable